#!/usr/bin/perl -w
# n e t  d i s c o
# Created for UCSC
# Changes in code from 0.92 on:
# Copyright (c) 2003-2010 Max Baker and the Netdisco Developer Team - All Rights Reserved
# (C) 2002,2003 UC Regents.  See bottom of this file.
# $Id: netdisco,v 1.195 2011/03/31 10:22:31 olly_g Exp $

=head1 NAME

netdisco - Internal API

=head1 DESCRIPTION

This is the inside guts of the Netdisco executable.  You should be looking in 
README for how to use Netdisco.

=cut

use strict;
use Getopt::Long;
use FindBin;             # Add this directory for netdisco.pm
use lib $FindBin::Bin;
use IO::File;            # For batch_mode()
use POSIX qw/:errno_h setsid/;  # for Admin Daemon
use Compress::Zlib;
use netdisco qw/:all/;  
tryuse('SNMP::Info', ver => '2.04', die => 1);

$| = 1;

# Signal Handlers
$SIG{INT}  = \&end_int_handler;
$SIG{ALRM} = \&timeout;

# --------------------------------------------------------------
#                         Globals                               
# --------------------------------------------------------------
use vars qw/$DEBUG %CONFIG %Discovered %Discovered_Alias @Discover_Queue %NoCDP %UnDiscovered
            %TimedOut $Aliases $OldDevices $OldNodes $PortMAC $start_time $end_time
            @OldSTDOUT @LogFH @LogFile %DeviceTopo %args $configfile $BatchMode $Log
            $New_Only $VERSION $DaemonMode $nprocs $controller/;

$VERSION = '1.1';
%Discovered = ();
%Discovered_Alias = ();
@Discover_Queue = ();
%NoCDP = ();
%UnDiscovered = ();
%TimedOut = ();
$Aliases = undef;
$OldDevices = undef;
$PortMAC = undef;
$DaemonMode=$start_time=$end_time=0;
@OldSTDOUT = ();
@LogFH     = ();
@LogFile   = ();
%DeviceTopo = ();
$nprocs     = 1;
$controller = 0;

# --------------------------------------------------------------
#              Command Line Flags                               
# --------------------------------------------------------------
Getopt::Long::Configure('no_ignore_case');
GetOptions(\%args,'a|arpwalk',
                  'A|arpnip=s',
                  'b|batchmode',
                  'B|backup',
                  'C|configfile=s',
                  'd|discover=s',
                  'D|debug+',
                  'e|expirenodes=s',
                  'E|expiredevice=s',
                  'expire-nodes-subnet=s',
                  'F|discoverfile=s',
                  'g|graph',
                  'h|help',
                  'I|expireips',
                  'i|changeip=s',
                  'j|saveconfigs=i',
                  'k|cleanalias',
                  'K|cleannodes',
                  'L|nologging',
                  'm|macwalk',
                  'M|macsuck=s',
                  'n|nodestoo',
                  'N|newonly',
                  'O|oui',
                  'P|port=s',
                  'p|daemon=s',
                  'r|discoverall=s',
                  'S|dumpsql',
                  'R|refresh',
                  't|test',
                  'T|topofile',
                  'u|user',
                  'v|version|ver',
                  'V|archive',
                  'w|nbtwalk',
                  'W|nbtstat=s',
          );
$DEBUG             = $args{D} || 0;
$netdisco::SQLCARP = $args{S} || 0;
$BatchMode         = $args{b} || 0;
$New_Only          = $args{N} || 0;
$Log               = $BatchMode && !defined $args{L};

# Allow the -h or -v commands to run no matter what
defined $args{h} and &usage;
defined $args{v} and &version;

# Print Header
&header if (grep(/^([aABdeEFgIijkKmMOprRTu]|expire-nodes-subnet)$/,keys %args) and !$BatchMode);

# Parse Config File - Check for -C, then in current dir, then in default dir.
foreach my $c ($args{C},"$FindBin::Bin/netdisco.conf",'/usr/local/netdisco/netdisco.conf') {
    if (defined $c and -r $c){
        $configfile = $c;
        print "Using Config File : $configfile\n" if $DEBUG;
        last;
    }
}

unless (defined $configfile){
    print "No Config file found, or permission denied!\n";
    exit;
}

config($configfile);

# --------------------------------------------------------------
#             Run Commands                                      
# --------------------------------------------------------------

#   Discovery
defined $args{R} and &refresh_all;
defined $args{d} and &topo_load_file;
defined $args{d} and &discover($args{d});
defined $args{r} and &run($args{r});
if (defined $args{F} or defined $args{T}) {
    &schlop( defined $args{F} ? $args{F} : homepath('topofile'), 
             defined $args{T}
           );
}

#   Mac Sucking
defined $args{M} and &macsuck($args{M});
defined $args{m} and &macwalk;

#   Arp Nipping
defined $args{a} and &arpwalk;
defined $args{A} and &arpnip($args{A});

#   NetBIOS
defined $args{w} and &nbtwalk;
defined $args{W} and &nbtstat($args{W});

#   Other
defined $args{j} and &save_dirty_configs($args{j});
defined $args{K} and &db_clean;
defined $args{k} and &alias_clean;
defined $args{g} and &graph;
defined $args{t} and &test;
defined $args{O} and &parse_oui;
defined $args{B} and &nightly;
defined $args{E} and &expire_device($args{E},defined $args{n});
defined $args{e} and &expire_nodes($args{e},defined $args{V},$args{P});
defined $args{I} and &expire_ips;
defined $args{i} and &change_device_ip($args{i},shift @ARGV);
defined $args{p} and &admin_daemon_ctl($args{p});
defined $args{u} and &add_user(@ARGV);
defined $args{'expire-nodes-subnet'} and &expire_nodes_subnet($args{'expire-nodes-subnet'});

# Make sure we ran a command, else spit out the usage
&usage unless ( grep(/^([aABdeEFgiIjkKmMnNOprRtTuwW]|expire-nodes-subnet)$/,keys %args) );
exit;

=head1 FUNCTIONS

=head2 Network Discovery

=over

=item discover(host) 

Discovers one device, stores its info, interfaces, and neighbors, and returns.

=cut

sub discover{
    my $hostname = shift;

    print "[$hostname] Discover starting\n";

    my $ip = getip($hostname);
    return 0 unless ok_to($ip, $hostname, 'discover');

    my $device = get_device($hostname) or return 0;
    $ip        = $device->{ip};

    # Store Device Info
    store_device($device);

    # Walk Interfaces
    store_interfaces($device);
    store_vlans($device);
    store_power($device);

    # Walk Modules
    if (!defined($CONFIG{'store_modules'}) || $CONFIG{'store_modules'}) {
        store_modules($device);
    }

    # Walk neighbors
    find_neighbors($device);

    # Manual Topology Info
    topo_add_link( $DeviceTopo{$ip} ) if defined $DeviceTopo{$ip}; 

    $Discovered{ $ip }++;

    foreach my $alias (keys %{$device->{_alias}}){
        next unless defined $alias and length($alias);
        $Discovered_Alias{ $alias } = $ip;
    }

    return 1;
}

=item refresh_all()

Calls discover() for each file already in device table.

=cut

sub refresh_all {
    $start_time = time;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/refresh");

    my $now = localtime();
    print "[Refresh All Devices]  Started at $now. \n";
    &load_old_devices;
    &topo_load_file;

    my $timeout = $CONFIG{timeout};

    $controller = $$;

    sql_begin();
    foreach my $dev (keys %$OldDevices){
        next unless ok_to($dev, $dev, 'discover');
        queue_process($dev, 'rediscover');
    }
    sql_commit();
    dispatcher('rediscover', \&discover);

    sql_vacuum('device','print'=>1);
    sql_vacuum('device_port','print'=>1);
    sql_vacuum('device_ip','print'=>1);
    &end;

}

=item run() 

Event loop that calls discover() as long as the @Discover_Queue has something in it.

=cut

sub run {
    my $root_device = shift;
    
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("discover/$month/discover_net",1);

    print "Network discovery starting from root $root_device at " . localtime() . "\n";

    my @root_dev_list = split(/\s*,\s*/, $root_device);
    foreach my $root_dev (@root_dev_list) {
        my $root_dev_ip = &getip($root_dev);
        unless (defined $root_dev_ip){
            print "Cannot resolve $root_dev to an IP address.\n";
        } else {
            push(@Discover_Queue, $root_dev_ip);
        }
    }
    print "start from " . scalar(@Discover_Queue) . " root device(s)\n"  if scalar(@Discover_Queue) > 1 && $DEBUG;
    if (scalar(@Discover_Queue) == 0) {
        print "No devices in discovery queue.\n";
        return;
    }
    my (@Root_Device_List) = @Discover_Queue;

    # Getting old devices for statistics.
    &load_old_devices;
    topo_load_file();

    $start_time = time;

    my $timeout = $CONFIG{timeout};

    
    while (my $this_dev = shift @Discover_Queue){ 
        # We've already been here.
        next if defined $Discovered{$this_dev};
        next if defined $Discovered_Alias{$this_dev};

        # We couldn't connect already, dont try again.
        next if defined $UnDiscovered{$this_dev};

        # New Only scan, ignore existing devices
        #   except let us rediscover our target(s)
        next if ( ((defined $OldDevices->{$this_dev} or defined $Aliases->{$this_dev}) and $New_Only)
                  and !grep($_ eq $this_dev, @Root_Device_List)
                );

        # Set time out 
        eval {
            alarm($timeout);
            discover($this_dev);
            alarm(0);   # Cancel alarm if we return in time.
        };

        if ($@) {
            if ($@ =~ /timeout/){
                $TimedOut{$this_dev}++;
                print "\n  ! Device Timed out ($timeout sec)\n";
            } else {
                print "\n$@\n";
            }
        }
    }
    
    print "Network Discovery complete.\n";
    
    sql_vacuum('device','print'=>1);
    sql_vacuum('device_port','print'=>1);
    sql_vacuum('device_ip','print'=>1);

    &end;
    
}

=item schlop(file,topo_only_flag) 

Used to start a discovery based on topography file.  Will then proceed to do an initial mac_suck() and arp_nip() unless the topo_only_flag is set.

=cut

sub schlop {
    my ($file,$topo_only) = @_;
    &batch_mode('discover_file');

    $start_time = time; 
    my $function = "Discovering devices";
    $function = "Discovering only new devices" if ($New_Only);
    $function = "Loading Topology" if ($topo_only);
    print "$function from file: $file...\n";

    &topo_load_file($file);
    &load_old_devices;

    $controller = $$;

    # Add devices
    foreach my $dev (keys %DeviceTopo){
        next if ($New_Only and defined $OldDevices->{$dev});
        last if defined $topo_only and $topo_only;

        my $timeout = defined $CONFIG{timeout} ? $CONFIG{timeout} : 90;

        eval {
            alarm($timeout);
            discover($dev);
            alarm(0);   # Cancel alarm if we return in time.
        };

        if ($@) {
            if ($@ =~ /timeout/){
                $TimedOut{$dev}++;
                print "\n  ! Device Timed out ($timeout sec)\n";
            } else {
                print "\n$@\n";
            }
        }
    }
    
    # Deal with topology info
    foreach my $dev (keys %DeviceTopo){
        topo_add_link($DeviceTopo{$dev}); 
    }

    return if (defined $topo_only and $topo_only);

    # ArpNip and Macsuck newly found devices.
    &load_old_devices;
    &mac_getportmacs;

    sql_begin();
    foreach my $dev (keys %DeviceTopo){
        $dev = root_device($dev);
        my $layers = $OldDevices->{$dev};
        unless (defined $dev and defined $layers and length($layers)){
            print "  Device $dev not discovered. Skipped.\n";
            next;
        }

        queue_process($dev, 'macsuck') if (has_layer($layers,2));
        queue_process($dev, 'arpnip')  if (has_layer($layers,3));
    }
    sql_commit();
    dispatcher('macsuck', \&macsuck);
    dispatcher('arpnip', \&arpnip);

    foreach my $dev (@Discover_Queue){
        next if (defined $OldDevices->{$dev} or defined $Aliases->{$dev});
        print "  Found new device: $dev\n";
    }
    &end;
}

=item queue_process(device, action, [status])

Queue a request for this controller to perform an action.

=cut

sub queue_process {
    my ($device, $action, $status) = @_;

    insert_or_update('process', undef,
            {controller => $controller,
             device => $device,
             action => $action,
             status => $status || 'queued'});
}

=item topo_add_link([{},{}])

Pass reference to array of hash references holding link: lines from 
manual topology info.  Adds information to device_port table.

=cut

sub topo_add_link {
    my $links = shift;

    foreach my $link (@$links){
        next unless defined $link;

        unless ( defined $link->{from} and 
                 defined $link->{from_port} and
                 defined $link->{to} and
                 defined $link->{to_port} ) {
            print "  topo_add_link() - Bad link! ", join(',',each %$link), "\n";
            next;
        }
        my $from_descr = "$link->{from_name} ($link->{from}) / $link->{from_port}";
        my $to_descr = "$link->{to_name} ($link->{to}) / $link->{to_port}";
        my $link_descr = $from_descr . " --> " . $to_descr;
            
        # Add link info
        print "  topo_add_link() $link_descr\n" if $DEBUG;

        my $from = root_device($link->{from});
        if (!defined($from)) {
            print "  topo_add_link() - can't resolve $link->{from_name} ($link->{from}) into device - discover with -F?\n";
            next;
        }
        my $to = root_device($link->{to});
        if (!defined($to)) {
            print "  topo_add_link() - can't resolve $link->{to_name} ($link->{to}) into device - discover with -F?\n";
            next;
        }

        # Check for existing / conflicting topology info
        my $link_from = sql_hash('device_port', 
                            ['remote_ip','remote_port'],
                            { 'ip' => $from, 'port' => $link->{from_port} }
                            );
        my $link_to = sql_hash('device_port', 
                            ['remote_ip','remote_port'],
                            { 'ip' => $to, 'port' => $link->{to_port}  }
                            );

        # Check for destinations
        unless (defined $link_from) {
            print "    !topo_add_link() -  Topology file error! Source Port Doesn't exist in this link : $link_descr\n";
            next;
        }
        # Check for destinations
        unless (defined $link_to) {
            print "    !topo_add_link() -  Topology file error! Destination Port Doesn't exist in this link : $link_descr\n";
            next;
        }

        # See if from -> to direction conflicts
        # (Note: using addresses in topo file, not root device)
        if ((defined $link_from->{remote_ip} and $link_from->{remote_ip} ne $link->{to})
          or(defined $link_from->{remote_port} and $link_from->{remote_port} ne $link->{to_port})) {
            print "    !topo_add_link() - $from_descr has discovered neighbor ",
                  "$link_from->{remote_ip} / $link_from->{remote_port} which conflicts with ",
                  "forced info of $to_descr\n";
        }

        # See if to -> from direction conflicts
        # (Note: using addresses in topo file, not root device)
        if ((defined $link_to->{remote_ip} and $link_to->{remote_ip} ne $link->{from})
          or(defined $link_to->{remote_port} and $link_to->{remote_port} ne $link->{from_port})) {
            print "    !topo_add_link() - $to_descr has discovered neighbor ",
                  "$link_to->{remote_ip} / $link_to->{remote_port} which conflicts with ",
                  "forced info of $from_descr\n";
        }

        my $rv = insert_or_update('device_port',
                        {'ip' => $from, 'port' => $link->{from_port} },
                        {'remote_ip' => $to, 'remote_port' => $link->{to_port} }
                        );
        print "    topo_add_link() - Failed to add $link_descr\n" if $rv;
    }
}

=item topo_load_file(filename) 

Loads and parses manual topography file. 

=cut

sub topo_load_file {
    my $file = shift;

    $file = homepath('topofile') unless $file;

    my $dev;    # current config line
    my $from;   # "name" of current device

    print "Loading topology information from $file\n" if $DEBUG;
    open (DEVS,"<$file") or die "topo_load_file($file)  $!\n";
    while (my $line = (<DEVS>)){
        chomp $line;
        # comments
        $line =~ s/(?<!\\)#.*//;
        # Handle escaped pound signs
        $line =~ s/\\#/#/g;

        # White Space
        $line =~ s/^\s+//g;
        $line =~ s/\s+$//g;
        next if $line =~ /^\s*$/;
        
        if ($line =~ /^link:(.*)/){
            my ($from_port,$to,$to_port) = split(/,/,$1);

            unless (defined $dev){
                print "Skipping $line. No dev defined.\n" if $DEBUG;
                next;
            }

            my $to_ip = &getip($to);
            unless (defined $to_ip and length $to_ip){
                print "    Can't resolve $to in $line!\n";
                next;
            }

            # Resolve the destination to the canonical IP if it's
            # in our database.
            my $root_ip = root_device($to_ip);
            if ($root_ip) {
                $to_ip = $root_ip;
            }
        
            # Save Link info both directions
            push (@{$DeviceTopo{$dev}},   {'from' => $dev,  'from_port' => $from_port, 'from_name' => $from, 'to' => $to_ip, 'to_port' => $to_port,   'to_name' => $to});
            push (@{$DeviceTopo{$to_ip}}, {'from' => $to_ip,'from_port' => $to_port,   'from_name' => $to,   'to' => $dev,   'to_port' => $from_port, 'to_name' => $from});

        } elsif ($line =~ /^alias:(.*)/){
            unless (defined $dev){
                print "Skipping $line. No dev defined.\n" if $DEBUG;
                next;
            }
            print "  Alias : $1 found.\n" if $DEBUG;
            next;

        } else {
            $from = $line;
            $dev = &getip($from);
            unless (defined $dev and length $dev){
                print "Bad line or device IP not found in $file : $line\n";
                next;
            } else {
                #print "    $line ($dev)\n" if $DEBUG;
            }
            # Resolve the destination to the canonical IP if it's
            # in our database.
            my $root_ip = root_device($dev);
            if ($root_ip) {
                $dev = $root_ip;
            }
        
            $DeviceTopo{$dev} = [] unless defined $DeviceTopo{$dev};
        }
    }
    close (DEVS);

    print scalar(keys(%DeviceTopo)) . " entries loaded \n" if $DEBUG;

}

=back

=head2 Utility Functions

=over

=item add_user()

Takes 4 optional arguments from @ARGV = (user,pw,port,admin) 

If all 4 are not there, then interactive mode is entered and prompts are given.

=cut

sub add_user {
    my ($user, $pw, $port, $admin, $fullname) = @_;

    my %args;
    unless (defined $user){
        print "Enter User Name : ";
        $user = <STDIN>;
        chomp $user;
    }

    unless ($user){
        print "User Name is required.\n";
        return;
    }

    unless (defined $pw){
        print "Enter new password for $user [no change]: ";
        $pw = <STDIN>;
        chomp $pw;
    }
    unless (defined $port){
        print "Give $user Port Control [no change]? ";
        $port = <STDIN>;
        chomp $port;
    }
    unless (defined $admin){
        print "Give $user Admin Rights [no change]? ";
        $admin = <STDIN>;
        chomp $admin;
    }
    unless (defined $fullname){
        print "User Full Name [none]? ";
        $fullname = <STDIN>;
        chomp $fullname;
    }

    print "$user $pw $port $admin $fullname\n" if $DEBUG;

    my $rv = user_add($user, admin => $admin, port => $port, pw => $pw, fullname => $fullname);

    if ($rv) { 
        print "Added user $user. ($rv)\n";
    }  else {
        print "Added / Changed user $user\n";
    }
}

=item batch_mode(name,time_too?)

Redirects STDOUT to a log file with timestamp.

Can be called recursively.  call batch_mode_end() to return to previous Output.

=cut

sub batch_mode{
    return unless $BatchMode;

    my ($file_name,$want_time,$no_header) = @_;

    my $file_path = homepath('datadir','data');

    my $extension = defined $CONFIG{logextension} ? $CONFIG{logextension} : 'log';
    
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();

    # YYYYMMDD-HHmm
    my $date = sprintf("%d%02d%02d",$year+1900,$mon+1,$mday);
    my $time = sprintf("%02d-%02d",$hour,$min);

    my $timestamp = (defined $want_time and $want_time) ? "$date-$time" : $date;
    
    my $file = "$file_path/$file_name-$timestamp.$extension";

    # Path is everything up to the last /
    my $path = "";
    my @path = split(m|/|, $file);
    for (my $elem = 1; $elem < $#path; $elem++) {
        $path .= "/" . $path[$elem];
        # Make the target directory if not already there
        unless (-d $path){
            mkdir ($path,0775) or die "Can't make directory $path. $!\n";
        }
    }

    my $fh = new IO::File;
    my $old_umask = umask(0000);
    $fh->open($file,O_WRONLY|O_CREAT,0664) or die "Can't open $file. $!\n";
    umask($old_umask);
    
    # Redirect output to log
    push (@OldSTDOUT, select($fh) );
    push (@LogFH,$fh);
    push (@LogFile,$file);

    # No Buffering output
    $| = 1;

    print STDERR "Batch Mode - Output in $file\n" if $DEBUG;
    &header unless (defined $no_header and $no_header);
}

=item batch_mode_end(no_compress_flag)

Returns control of stdout to previous value, optionally compresses 
the finished output file.

Function returns file name of closed output file.

Pass something as first parameter to force no compression.

=cut

sub batch_mode_end {
    my $no_compress = shift;
    return unless $BatchMode;

    return unless scalar @LogFile;

    my $file = pop @LogFile;
    select (pop @OldSTDOUT);
    my $fh = pop @LogFH;
    $fh->close() or die "Can't write $file. $!\n";

    if (defined $CONFIG{compresslogs} and $CONFIG{compresslogs} and ! defined $no_compress){
       print STDERR "\tCompressing $file\n" if $DEBUG;
       open(OLD, "< $file") or die "Can't open $file: $!\n";
       my $gz = gzopen("$file.gz", "wb") or die "Can't open $file.gz: $gzerrno\n";
       while (<OLD>) {
           $gz->gzwrite($_) 
              or die "Error writing: $gzerrno\n" ;
       }
       $gz->gzclose ;
       close(OLD)      or die "Can't close $file: $!\n";
       unlink($file)   or die "Can't delete $file: $!\n";
    }
    
    return $file;
}

=item end_int_handler 

=cut

sub end_int_handler {
    &end;
    &batch_mode_end;
    exit;
}

=item end()

Cleanup routine that is called upon interrupt (ctrl-c) or end of routines. 

Prints various statistics to stdout or batch_redirect() and calls Netdisco::log().

=cut

sub end {
    return unless $start_time != 0;
    # If we're in multi-process mode, but we're not the controller, it's
    # not our job to do this.
    return if ($controller != 0 && $controller != $$);

    $end_time = time;
    my $run_time = sprintf("%-.2f",($end_time-$start_time)/60);
    print "\n" .'-'x70 . "\n";
    print "Run took $run_time minutes\n";

    my $status = sql_rows('process', ['action','count(*) as num','sum(count) as tot'],
        {'controller' => $controller}, 0, 'GROUP BY action');
    # and status = done?

    my %actions = ();
    foreach my $action (@$status) {
        $actions{$action->{action}} = $action;
    }

    if ($actions{arpnip}) {
        my $ArpTotal = $actions{arpnip}->{tot} || 0;
        my $ArpDevices = $actions{arpnip}->{num};
        print "Found $ArpTotal arp cache entries from $ArpDevices devices.\n";
        log('arp',"$ArpTotal entries. $ArpDevices devices. $run_time minutes.",$LogFile[-1]) if $Log;
    }

    if ($actions{nbtstat}){
        my $NbtTotal = $actions{nbtstat}->{tot} || 0;
        my $nodes = $actions{nbtstat}->{num};
        my $pct   = $nodes ? sprintf("%2.2f",($NbtTotal/$nodes)*100) : 0;
        print "Found $NbtTotal/$nodes ($pct\%) nodes with NetBIOS entries.\n";
        log('netbios',"$NbtTotal/$nodes ($pct\%) nodes w/ NetBIOS. $run_time minutes.",$LogFile[-1]) if $Log;
    }

    if ($actions{macsuck}){
        my $MacTotal = $actions{macsuck}->{tot} || 0;
        my $MacDevices = $actions{macsuck}->{num};
        print "Found $MacTotal forwarding table entries from $MacDevices devices.\n";
        log('mac',"$MacTotal forwarding table entries.  $MacDevices devices.  $run_time minutes.",$LogFile[-1]) if $Log;
    }

    # this will eventually be for discover too.
    foreach my $action (qw/rediscover/) {
        if ($actions{$action}) {
            my $discover_count = $actions{$action}->{tot} || 0;
            my %where = ('controller' => $controller, 'action' => $action);
            my $TimedOut = sql_column('process',['device','count'],{ %where, status => 'timedout' });
            $where{'count'} = 1;
            my $Discovered = sql_column('process',['device','count'],\%where);
            $where{'count'} = 0;
            $where{'status'} = '!timedout';
            my $UnDiscovered = sql_column('process',['device','count'],\%where);

            # Check for new/old devices
            my $new = 0;
            my $old = scalar keys %$OldDevices;

            foreach my $device (keys %$Discovered){
                $new++ unless defined $OldDevices->{$device};
            }

            foreach my $device (keys %$OldDevices){
                $old-- if defined $Discovered->{$device};
            }

            print "Discovered : $new new devices.  Missed: $old old devices.\n";

            log($action,"$discover_count devices. ($new new) ($old old) $run_time minutes.",$LogFile[-1]) 
                if $Log;

            if (scalar keys %$UnDiscovered) {
                print "Devices Found by CDP but not reachable by SNMP : \n";
                foreach my $dev (keys %$UnDiscovered){
                    print "    $dev\n";
                } 
                log('nosnmp',join(' ',keys %$UnDiscovered),$LogFile[-1]) if $Log;
            }

            # XXX todo: NoCDP

            if (scalar keys %$TimedOut){
                print "Devices timed out : \n";
                foreach my $dev (keys %$TimedOut){
                    print "    $dev\n";
                }
                log('timeout',join(' ',keys %$TimedOut),$LogFile[-1]) if $Log;
            }
        }
    }

    #XXX this is just for old discover now and will be deleted
    my $discover_count = scalar(keys(%Discovered));
    if ($discover_count){
        print "Discovered $discover_count devices.\n";

        # Check for new/old devices
        my $new = 0;
        my $old = scalar keys %$OldDevices;

        foreach my $device (keys %Discovered){
            $new++ unless defined $OldDevices->{$device};
        }

        foreach my $device (keys %$OldDevices){
            $old-- if defined $Discovered{$device};
        }

        print "Discovered : $new new devices.  Missed: $old old devices.\n";

        log('discover',"$discover_count devices. ($new new) ($old old) $run_time minutes.",$LogFile[-1]) 
            if $Log;

        if (scalar keys %NoCDP){
            print "Devices Found by CDP but without CDP info avail. via SNMP :\n";
            foreach my $dev (keys %NoCDP){
                print "    $dev\n";
            } 
            log('nocdp',join(' ',keys %NoCDP),$LogFile[-1]) if $Log;
        }
        
        if (scalar keys %UnDiscovered) {
            print "Devices Found by CDP but not reachable by SNMP : \n";
            foreach my $dev (keys %UnDiscovered){
                print "    $dev\n";
            } 
            log('nosnmp',join(' ',keys %UnDiscovered),$LogFile[-1]) if $Log;
        }

        if (scalar keys %TimedOut){
            print "Devices timed out : \n";
            foreach my $dev (keys %TimedOut){
                print "    $dev\n";
            }
            log('timeout',join(' ',keys %TimedOut),$LogFile[-1]) if $Log;
        }
    }
    if ($controller) {
        # clean up process table
        sql_do(qq/DELETE FROM process WHERE controller='$controller'/);
    }
    &batch_mode_end;
    if ($DaemonMode){
        return;
    }
    exit;
}

=item load_old_devices()

Populates %Old_Devices with which devices are in the database.

=cut

sub load_old_devices {
    print "load_old_devices()\n" if $DEBUG;
    $OldDevices = sql_column('device',['ip','layers']);
    $Aliases = sql_column('device_ip',['alias','ip'],{'ip' => \\'!= alias'});
}

=item load_old_nodes(days)

Populates %Old_Nodes with which nodes are in the database.

Nodes will have to have been seen in the last DAYS days.

=cut

sub load_old_nodes {
    my $days = shift;
    print "load_old_nodes()\n" if $DEBUG;
    my $where = {active=>1, 
        'mac'=>\\"in (select mac from node where active)" };
    if (defined $days){
        $where->{'age(time_last)'}=\\"<= interval '$days day'"; 
    }
    my $old_nodes = sql_rows('node_ip',['ip'],$where);
    foreach my $n (@$old_nodes){
        my $ip = $n->{ip};
        $OldNodes->{$ip}++;
    }
}

=item parse_oui()

Parses file oui.txt in current directory.  Uses contents to stuff
table "oui".

=cut

sub parse_oui {
    print "parse_oui()\n";
    my $oui_file = "$CONFIG{home}/oui.txt";
    unless (-r $oui_file){
        print "  $oui_file not found!\n";
        die "Please run ''make oui'' to download oui.txt.  Or read INSTALL\n";
    }
    print "Removing old contents of oui table in database.\n";
    sql_do(qq/DELETE FROM oui WHERE true/);
    print "Schlopping contents of oui.txt to database.\n";
    my %OUI;
    open (OUI, "<$oui_file") or die "Can't open OUI. $!\n";
    while (my $line = <OUI>){
        chomp $line;
        if ($line =~ /^(.{2}-.{2}-.{2})\s+\(hex\)\s+(.*)\s*$/i){
            $OUI{$1}=$2;
        } 
    }
    close (OUI);

    my $oui_count = 0;
    foreach my $oui (keys %OUI){
        my $company = $OUI{$oui};
        # make 00-00-00 into 00:00:00
        $oui =~ s/-/:/g;
        $oui = lc($oui);
        print "$oui : $company\n" if $DEBUG;
        insert_or_update('oui',{},{'oui' => $oui, 'company' => $company } );
        $oui_count++;
    }
    print "Added $oui_count entries from oui.txt\n";
    sql_vacuum('oui',full=>1,'print'=>1);
}

=item timeout()

Signal handler for SIGALARM

=cut

sub timeout {
    die "timeout";
}

=item ok_to(dev,name,what)

Given a device or IP address, a display name (hostname or IP address),
and an action (arpnip, macsuck, discover), check the configuration
file for _no and _only configurations.  Return 1 if it's OK, or 0
if it's not OK.

=cut

sub ok_to {
    my $dev = shift;
    my $name = shift;
    my $what = shift;

    my $no = $what . "_no";
    my $only = $what . "_only";
    
    if (in_device($dev,$CONFIG{$no}) ||
        ($CONFIG{$only} && !in_device($dev,$CONFIG{$only}))) {
        print "[$name] Excluded from $what in config file.\n";
        return 0;
    }

    my $min_age = $what . "_min_age";
    if ($CONFIG{$min_age}) {
        my $col = sprintf("extract( epoch from (age(now(), last_%s) ) )", $what);
        my $val = $CONFIG{$min_age};
        my $ip;

        # Passed a sql_hash from the device table
        if (ref($dev) eq 'HASH'){
            $ip     = $dev->{ip};
        # Passed as simple hostname/IP
        } else {
            $ip     = &getip($dev);
        }
        my $res = sql_scalar('device',[$col],{'ip'=>$ip});
        if ($res and $res < $val) {
            printf("[%s] skipped: last %s was %d seconds ago, which is less than specified in config file (%s = %s).\n",
                $name, $what, $res, $min_age, $val);
            return 0;
        }
    }
        
    return 1;
}

=back

=head2 SNMP Functions

=over

=item arpnip() 

Connects to device and reads its ARP cache. Then adds entries to C<node_ip> table. 

Cheers to Jim Warner for the original arpnip.

=cut

sub arpnip {
    my $hostname = shift;

    my $ip = getip($hostname);

    print "arpnip($hostname) :\n";

    unless (defined $ip){
        print "[$hostname] Name does not resolve with DNS.\n";
        return;
    }

    $ip = root_device($ip);

    # all numeric host name (bad) looks like an IP but fails.
    unless (defined $ip){
        print "  IP not resolved.\n";
        return;
    }

    my $dev = sql_hash('device',['*'],{'ip'=>$ip});

    unless (defined $dev->{ip}) { 
        print "  Device not found in database.  Try ``netdisco -N -r $hostname''\n";
        return;
    }

    return unless ok_to($dev, $hostname, 'arpnip');

    my $device = get_device($hostname);
    return unless defined $device;

    &mac_getportmacs unless defined $PortMAC;

    # Fetch ARP Cache
    my $at_paddr = $device->at_paddr();
    my $at_netaddr = $device->at_netaddr();

    my $arp_count =0;
    sql_begin(['node_ip']);
    foreach my $arp (keys %$at_paddr){
        my $mac = $at_paddr->{$arp};
        my $ip = $at_netaddr->{$arp};

        next unless defined $ip;

        # BayRS routers report incomplete MAC addresses for frame relay DLCI
        # interfaces.  Include this check for this case plus any others.
        unless (&is_mac($mac)) {
            print "[$hostname] $mac malformed ... skipping\n" if $DEBUG;
            next;
        }
        # Skip network broadcast addresses.  Some devices use this and then the
        # broadcast IP will show up in the node table.
        next if uc($mac) eq 'FF:FF:FF:FF:FF:FF';
        
        # Skip Passport 8600 CLIP MAC addresses, they will be used as root IP if
        # present so the IP will be identified.  Do not let the bogus MAC make
        # them show up in the node table.
        next if uc($mac) eq '00:00:00:00:00:01';
    
        # Skip VRRP addresses - don't want them showing up as nodes.  Don't know
        # what else to do with these right now.  What about HSRP IP's?
        if ($mac =~ /^00:00:5e:00:/i) {
            print "[$hostname] $mac is a VRRP address ... skipping\n" if $DEBUG;
            next;
        }

        if (defined $PortMAC->{$mac}) {
            print "[$hostname]  $mac is a port on device $PortMAC->{$mac} ... skipping\n"
                if $DEBUG;
            next;
        }   

        print "[$hostname]  $ip : $mac\n" if $DEBUG;
        add_arp($mac,$ip);
        $arp_count++;
    }
    sql_commit();
    print "[$hostname]  Processed $arp_count ARP Cache entries.\n";
    
    insert_or_update('device',{'ip'=> $dev->{ip} },{'last_arpnip'=> scalar localtime});

    # Fetch Subnets
    get_subnets($device);

    # Try walking IPv6 Neighbor cache too
    # FIXME: Temporary solution, perhaps arpnip6 should be a completely seperate action
    &arpnip6($hostname);

    return $arp_count;
}

=item arpnip6() 

Connects to device and reads its IPv6 Neighbor cache. Then adds entries to C<node_ip> table. 

Largely the same as arpnip().

=cut

sub arpnip6 {
    my $hostname = shift;

    my $ip = getip($hostname);

    print "arpnip6($hostname) :\n";

    unless (defined $ip){
        print "[$hostname] Name does not resolve with DNS.\n";
        return;
    }

    $ip = root_device($ip);

    # all numeric host name (bad) looks like an IP but fails.
    unless (defined $ip){
        print "  IP not resolved.\n";
        return;
    }

    my $dev = sql_hash('device',['*'],{'ip'=>$ip});

    unless (defined $dev->{ip}) { 
        print "  Device not found in database.  Try ``netdisco -N -r $hostname''\n";
        return;
    }

    return unless ok_to($dev, $hostname, 'arpnip6');

    my $device = get_device($hostname);
    return unless defined $device;

    &mac_getportmacs unless defined $PortMAC;

    # Fetch IPv6 Neighbor Cache
    my $phys_addr = $device->ipv6_n2p_mac();
    my $net_addr = $device->ipv6_n2p_addr();

    my $arp_count =0;
    sql_begin(['node_ip']);
    foreach my $arp (keys %$phys_addr){
        my $mac = $phys_addr->{$arp};
        my $ip = $net_addr->{$arp};

        next unless defined $ip;

        if (defined $PortMAC->{$mac}) {
            print "[$hostname]  $mac is a port on device $PortMAC->{$mac} ... skipping\n"
                if $DEBUG;
            next;
        }   

        print "[$hostname]  $ip : $mac\n" if $DEBUG;
        add_arp($mac,$ip);
        $arp_count++;
    }
    sql_commit();
    print "[$hostname]  Processed $arp_count IPv6 Neighbor Cache entries.\n";
    
    # FIXME: should we add a new field to the device table to hold last_arpnip6? Abuse last_arpnip? Don't store this value?
    #insert_or_update('device',{'ip'=> $dev->{ip} },{'last_arpnip'=> scalar localtime});

    # Fetch Subnets
    # FIXME: no IPv6 equivalent yet
    #get_subnets($device);

    return $arp_count;
}

=item arpwalk() 

Visits every Layer 3 device and trys to get its ARP Cache.  

Calls arpnip() for each device.  

=cut

sub arpwalk {
    $start_time = time;
    
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/arp",1);
    print "Grabbing Arp Cache from all layer 3 devices (". localtime() . ")...\n";

    # Get our old devices, IP->Layer mapping
    &load_old_devices;

    # Grab existing mac addresses for switch ports
    &mac_getportmacs;

    $controller = $$;
    sql_begin();
    foreach my $device (keys %$OldDevices){
        next unless ok_to($device, $device, 'arpnip');
        queue_process($device, 'arpnip')  if (has_layer($OldDevices->{$device},3));
    }
    sql_commit();
    dispatcher('arpnip', \&arpnip);

    sql_vacuum('node_ip','print'=>1);

    &end;
}

=item create_device(%args)

All %args are passed straight through to SNMP::Info except 'Class' which when set 
turns off C<AutoSpecify>.

 my $dev = create_device(
            'DestHost'     => host,
            'Community'    => public,
            'Version'      => 2,
            'Retries'      => 2,
            'Class'        => 'SNMP::Info::Layer2',
            'VersionForce' => 1,

Connect to a device via SNMP::Info with a given host and community string.

If optional C<Version> and C<Class> are given, no device type discovery is done.

If a more specific device type is not found C<-1> is returned.
The target device is probably not a network device.

If C<VersionForce> is true, no fallback to snmpv1 will happen.

=cut

sub create_device {
    my %args = @_;
    return undef unless defined $args{DestHost} and (defined $args{Community} || defined($args{SecLevel}));

    # Default Values
    $args{Debug}         = $DEBUG;
    $args{Version}       = $args{Version}       || $CONFIG{snmpver} || 2;
    $args{Retries}       = $CONFIG{snmpretries} || 2   unless defined $args{Retries};
    $args{Timeout}       = $CONFIG{snmptimeout} || 1000000 unless defined $args{Timeout};
    $args{MibDirs}       = $CONFIG{mibdirs}            if     defined $CONFIG{mibdirs};
    $args{BulkWalk}      = $CONFIG{bulkwalk_off} ? 0 : 1 if defined $CONFIG{bulkwalk_off};
    # Turn off bulkwalk automatically if we're using Net-SNMP 5.2.3 or 5.3.1.
    #  Even though the version numbers are now floats, previous
    #  versions reported as strings so we can't use "==".
    if ((!defined($args{BulkWalk})) &&
        ($SNMP::VERSION eq '5.0203' || $SNMP::VERSION eq '5.0301')) {
        print "! Turning off bulkwalk due to buggy Net-SNMP $SNMP::VERSION\n";
        $args{BulkWalk} = 0;
    }
    $args{BulkRepeaters} = $CONFIG{bulkwalk_repeaters} if     defined $CONFIG{bulkwalk_repeaters};
    $args{AutoSpecify}   = defined $args{Class} ? 0 : 1;
    $args{NonIncreasing} = defined $CONFIG{nonincreasing} ? $CONFIG{nonincreasing} : 1; # remove loops in bulkwalks
    my $class            = $args{Class}   || 'SNMP::Info';
    my $version_force    = $args{VersionForce}  || 0;

    # Arguments internal to this sub, not passed to SNMP::Info
    delete $args{Class}        if exists $args{Class};
    delete $args{VersionForce} if exists $args{VersionForce};
   
    my $print_comm = $args{Community} || $args{SecName} || "?";
    # If it's vlan, do last letter @ vlan
    if ($print_comm =~ /\@/){
        $print_comm =~ s/^.*(.\@\d+)$/$1/;  # VLAN Comm
    } else {
        # else do last letter
        $print_comm = substr($print_comm,-1,1);
    }
    if ($args{Context}) {
        $print_comm .= "/" . $args{Context};
    }
    printf("  create_device(%s,%s,%s,%s,bw:%s)\n",
           $args{DestHost},$print_comm, $version_force ? "$args{Version}*" : $args{Version}, 
           $args{AutoSpecify} ? 'AutoSpecify' : $class,
           defined $args{BulkWalk} ? $args{BulkWalk} : 'default',
          )
         if $DEBUG;


    my $device = new $class( %args );
    

    # Test for connectivity
    my ($layers , $descr);
    if (defined $device) {
        $layers = $device->layers();
        $device->error() unless $layers; # Clear error status that might have been caused by device w/o sysServices
        $descr = $device->description();
    }

    # Try Version 1 if we haven't already
    #   V1 screws up some HP switches that support 2, so we stick w/ 2 first
    #   Don't try V1 if we're forcing a specific version
    if ( (!defined $device or (!defined $layers and !defined $descr) ) and 
         $args{Version} != 1 and !$version_force ){
        
        print "[$args{DestHost}] [Trying SNMP Version 1]\n";
        printf("create_device(%s,%s,1)\n",$args{DestHost},$print_comm) if $DEBUG;
        $args{Version} = 1;
        
        $device = new $class(%args);
    }
    
    unless (defined $device) {
        $DEBUG and print "  Can't connect to $args{DestHost}\n";
        return undef;
    }

    $class = $device->class();
    if (!defined $device or !defined $class){
        $DEBUG and print "  Could not connect to $args{DestHost}.\n";
        return undef;
    }
        
    if ($class eq 'SNMP::Info'){
        my $layers = $device->layers();
        print "[$args{DestHost}]  Device Talks SNMP but only has layers $layers.  Skipping\n";
        return -1;
    }

    my $error = $device->error() || '';
    if ($error){
        # Debug already spit it out, no need to see it twice.
        print "[$args{DestHost}]  $error" unless $DEBUG;
        return undef;
    }

    $DEBUG and print "[$args{DestHost}]  Device Type : $class\n";

    # Tag on some netdisco specific info to the SNMP::Info object.
    $device->{ip}        = &getip($args{DestHost});
    $device->{dns}       = &hostname($device->{ip});

    return $device;
}

=item device_root() 

Looks to see if the device has a master IP instead of the one given.  
Checks for root_ip() method, then tries to lookup the reverse entry for sysName.0

=cut

sub device_root {
    my $device = shift;
    
    my $foundip = $device->{ip};

    # use the device override
    my $root_ip = $device->root_ip();
    return $root_ip if (defined $root_ip and length($root_ip));


    # Check the reverse of sysName.0 and use it for our real_ip?
    if (defined $CONFIG{reverse_sysname} and $CONFIG{reverse_sysname} ){
        my $name   = $device->name();
        my $nameip = &getip($name);

        print "  device_root(sysName.0 IP: $nameip Found IP:$foundip\n" if $DEBUG;
        return $nameip if (defined $nameip and length($nameip));
    }
    
    return $foundip;
}

=item find_neighbors() 

Finds all the CDP information on the device and stores the results in device_node.  

Adds to the @Discover_Queue

=cut

sub find_neighbors {
    my $device = shift;

    my $ip = $device->{ip};
    print "[$ip]  Fetching Neighbor Information\n";
    my $n_count = 0;
    my %seen;

    my $c_ip       = $device->c_ip();

    unless ($device->hasCDP() or scalar keys %$c_ip){
        # Great, catalyst 2926 doesnt give us cdpRun
        $NoCDP{$ip}++;    
        print "[$ip]   ! CDP not Enabled.\n";
        return;
    }

    my $c_if       = $device->c_if();
    my $c_port     = $device->c_port();
    my $c_id       = $device->c_id();
    my $c_platform = $device->c_platform();
    my $interfaces = $device->interfaces();

    my $remote_type_match = $CONFIG{discover_no_type} || '';

    sql_begin();
    foreach my $key (keys %$c_ip){
        # Get our port to iid mapping
        my $iid = $c_if->{$key};
        my $port = $interfaces->{$iid};

        unless (defined $port){
           print "[$ip]  - Port for IID:$iid not resolved.\n";
           next;
        }

        my $remote_ip   = $c_ip->{$key};
        my $remote_port = undef;
        my $remote_type = $c_platform->{$key};
        my $remote_id   = $c_id->{$key};

        # If we get unreachable (Cisco cluster) or
        # Local Loopback, try finding by remote_id.
        # This won't work for initial discovery, but
        # will after all devices are discovered.
        if ($remote_ip eq '0.0.0.0' or $remote_ip =~ /^127\./) {
            if ($remote_id) {
                print "[$ip]  - Got unusable address ($remote_ip) on port $port, looking up $remote_id.\n";
                my $try = sql_scalar('device',['ip'], {'name' => $remote_id});
                # device name might be truncated with long domain name.
                # Try removing the domain name altogether and use a wildcard
                if (!defined($try)) {
                    my $shortid = $remote_id;
                    $shortid =~ s/\..*//;
                    $try = sql_scalar('device',['ip'], {'name' => $shortid . '%'});
                }
                if (defined($try)) {
                    $remote_ip = $try;
                    print "[$ip]  - found $remote_id with IP address $remote_ip.\n";
                } else {
                    print "[$ip]  - could not find $remote_id, skipping.\n";
                    next;
                }
            } else {
                print "[$ip]  - Skipping unusable address ($remote_ip) on port $port.\n";
                next;
            }
        }

        if (exists($seen{$port}{$remote_ip})) {
            print "[$ip]  Port:$port skipping duplicate entry $remote_ip.\n";
            next;
        }
        else {
            %seen = ( $port => {$remote_ip => $remote_port} );
        }
        
        $n_count++;

        # Hack for BAY devices where if a BAY device is connected to a
        # non-bay device, we 'hear' other devices on the other end of this
        # port, but we don't know who we're talking to.
        # Therefore, set a loop back to ourselfs as a place marker, but add
        # our found nodes to the discovery queue.
        if ((ref $remote_ip eq 'ARRAY') or ( scalar(keys %{$seen{$port}}) > 1 )) {
            $DEBUG and print "[$ip]  Port:$port sees multiple neighbors. Setting loopback.\n";
            # Discover neighbors
            foreach my $neighbor (@$remote_ip){
                unless (defined $Discovered{$neighbor}) {
                    $DEBUG and print "[$ip]  Adding $neighbor to discovery queue.\n";
                    push (@Discover_Queue, $neighbor);
                }
            }
            # Set loopback
            $remote_ip   = $ip;
            $remote_port = $port;

        } else {
            $remote_port = $c_port->{$key};

            if (defined $remote_port) {
                # get rid of any weird characters
                $remote_port =~ s/[^\d\/\.,()\w:-]+//gi;

                # Swap catalyst remote port as 2/1 to 2.1
                $remote_port =~ s/\//\./ if ($remote_port =~ /^\d+\/\d+$/);
            } else {
                print "[$ip]  No remote_port found for Port:$port connected to $remote_ip.\n";
            }
        }

        next unless (defined $remote_ip and length($remote_ip));

        # IP Phone Detection -- Add known phone models in parens.
        if (defined $remote_type and $remote_type =~ /(mitel.5\d{3})/i) {
            $remote_type = 'IP Phone - '.$remote_type if $remote_type !~ /ip phone/i; 
        }

        my $port_exists = sql_scalar('device_port',['true'],{'ip'=>$ip,'port'=>$port});
        unless (defined $port_exists and $port_exists){
            print "[$ip]  Port $port not in DB -> $remote_ip/$remote_port.\n";
            next;
        }

        my %store;
        $store{'remote_ip'}   = $remote_ip;
        $store{'remote_port'} = $remote_port;
        $store{'remote_type'} = $remote_type;
        $store{'remote_id'}   = $remote_id;
       
        insert_or_update('device_port', {'ip' => $ip , 'port' => $port },
                        \%store);

        my $ok_to_discover = 1;
        if (defined $Discovered{$remote_ip}) {
            $DEBUG and print "[$ip]  $remote_ip already discovered.\n";
            $ok_to_discover = 0;
        }
        if (defined $Discovered_Alias{$remote_ip}) {
            $DEBUG and print "[$ip]  $remote_ip already discovered (alias of $Discovered_Alias{$remote_ip}).\n";
            $ok_to_discover = 0;
        }
        if (defined $remote_type and $remote_type_match and $remote_type =~ m/$remote_type_match/) {
            $DEBUG and print "[$ip]  $remote_ip excluded by discover_no_type.\n";
            $ok_to_discover = 0;
        }
        if ($ok_to_discover) {
            $DEBUG and print "[$ip]  Adding $remote_ip to discovery queue.\n";
            push (@Discover_Queue, $remote_ip);
        }
    }
    sql_commit();
    print "[$ip]   $n_count Neighbors.\n";
}

=item get_device(host)

Calls create_device() with a community string

If cached values are stored in the database for the SNMP version and community strings,
they are used. 

If no cached values are available, or if they fail, then the values from the config file are
tried.

=cut

sub get_device {
    my $hostname = shift;
    my $device   = undef;
    my $comm     = undef;

    print "  get_device($hostname)\n" if $DEBUG;

    # Check to see if device is in database
    my $ip       = &getip($hostname);
    my $dev_ip   = &root_device($ip);

    # Warn if we are using an alias
    if (defined $dev_ip and $dev_ip ne $ip){
        print "[$ip]    !is an alias of $dev_ip.\n";
    }

    # Call with stored comm/ver unless supplied $ver
    if (defined $dev_ip) { 
        my $row     = sql_hash('device',['*'],{'ip'=>$dev_ip});
        my $version = $row->{snmp_ver};
        $comm       = $row->{snmp_comm};

        printf("  get_device(%s) - Connecting using cached info: %s/%s/%s\n",$hostname,$dev_ip,substr($comm,-1,1),$version)
            if $DEBUG;

        my %args = get_snmp_args($row, $version, $comm);
        $args{VersionForce} = 1; # When using cached info, force use of cached snmp_ver without fallback
        $device = create_device(%args);
                               
        # a -1 return from create_device means that we *did*
        # talk to it, but it's a device type that we can't manage.
        # This means that it changed from when it was first put
        # into the database (or that SNMP::Info changed).
        if (defined($device) && $device == -1) {
            print "!  Talked to $dev_ip with SNMP community and version info in database but can't handle that type of device (check your SNMP::Info installation).\n";
            return undef;
        }
        print "!  Could not connect to $dev_ip with SNMP community and version info in database.\n"
            unless defined $device;
    }

    # Stored community not available, or didn't work. 
    if (!defined $device){
        my ($version) = check_snmp_version($hostname);

        my $list;
        if ($version and $version == 3) {
            # XXX should get_community do this instead?
            $list = $CONFIG{v3_users};
        } else {
            $list = get_community('ro',$hostname);
        }

        # Try each community string
        foreach my $config_comm (@{$list}) {

            # Don't bother retrying the failed one.
            next if (defined $comm and ($config_comm eq $comm));

            my %args = get_snmp_args($hostname, $version, $config_comm);

            $device = create_device(%args);

            if (defined $device and $device == -1){
                $device = undef;
                last;
            } elsif (defined $device){
                # refresh the db with new data
                print "! Storing device details back to database - new community string found.\n";
                store_device($device);
                last;
            }
        }
    }
    unless (defined $device) {
        $UnDiscovered{$ip}++ if defined $ip;
        print "! Device Not Supported or I can't connect to it via SNMP.\n";
        return undef;
    }
    return $device;
}

=item check_snmp_version(device,[version])

Check for a forced SNMP version by the configuration file arguments
snmpforce_v1, snmpforce_v2, snmpforce_v3
=cut

sub check_snmp_version {
    my($device,$version) = @_;
    my $versionForce;
    my $dev_ip;
    if (ref($device)) {
        $dev_ip = $device->{ip};
    } else {
        $dev_ip = $device;
    }

    if (!defined($version)) {
        $version = $CONFIG{snmpver};
    }
    $versionForce = 0;

    # Check for forced SNMP Verison
    if (in_device($device,$CONFIG{snmpforce_v1}) ) {
        print "! [$dev_ip]  Forcing SNMPv1 by config file.\n";
        $version      = 1;
        $versionForce = 1;
    }
    if (in_device($device,$CONFIG{snmpforce_v2}) ) {
        print "! [$dev_ip]  Forcing SNMPv2c by config file.\n";
        $version      = 2;
        $versionForce = 1;
    }
    if (in_device($device,$CONFIG{snmpforce_v3}) ) {
        print "! [$dev_ip]  Forcing SNMPv3 by config file.\n";
        $version      = 3;
        $versionForce = 1;
    }
    return ($version, $versionForce);
}

=item get_snmp_args(device,version,comm/user,rw)

Returns the args used to connect to device with version

=cut

sub get_snmp_args {
    my($device,$version,$user,$rw) = @_;
    my $dev_ip;
    if (ref($device)) {
        $dev_ip = $device->{ip};
    } else {
        $dev_ip = $device;
    }
    my %args = ('DestHost' => $dev_ip,
                'Version' => $version);
    # Check for bulkwalk disabling
    $args{BulkWalk} = 0 if in_device($device,$CONFIG{bulkwalk_no});

    my($forceversion, $force) = check_snmp_version($device);
    if ($force) {
        $args{Version} = $forceversion;
        $args{VersionForce} = 1;
    } else {
        $args{Version} = $version;
    }

    my %l2a = qw(none noAuthNoPriv auth authNoPriv enc authPriv priv authPriv);
    my %pref = qw(noAuthNoPriv 0 authNoPriv 1 authPriv 2);
    my %rpref = reverse %pref;
    if (defined $args{Version} and $args{Version} == 3) {
        my $v3user = $CONFIG{v3_user}{$user};
        return () unless defined($v3user);
        my ($levels, $authproto, $authpass, $privproto, $privpass) = split(/\s*:\s*/, $v3user);
        my @levels = split(/\s*,\s*/, $levels);
        @levels = map {$l2a{$_} || $_} @levels;
        my @prefs = sort map {$pref{$_}} @levels;
        my $level;
        if ($rw) {
            $level = $rpref{$prefs[$#prefs]};
        } else {
            $level = $rpref{$prefs[0]};
        }
        $args{SecName} = $user;
        $args{SecLevel} = $level;
        if ($level =~ /^auth/) {
            $args{AuthProto} = $authproto;
            $args{AuthPass} = $authpass;
        }
        if ($level eq 'authPriv') {
            $args{PrivProto} = $privproto;
            $args{PrivPass} = $privpass;
        }
    } else {
        $args{Community} = $user;
    }

    return %args;
}

=item get_device_rw(device[,version])

Returns a SNMP::Info object for a given device, using the Read-Write Community
Strings in the config file.

Returns undef or -1 on error.

=cut

sub get_device_rw {
    my ($hostname,$ver) = @_;
    my $device;

    my ($version) = check_snmp_version($hostname, $ver);

    my $list;
    if ($version == 3) {
        # XXX should get_community do this instead?
        $list = $CONFIG{v3_users};
    } else {
        $list = get_community('rw',$hostname);
    }

    foreach my $comm (@{$list}) {
        my %args = get_snmp_args($hostname, $version, $comm, 1);
        
        $device = create_device(%args);

        if (defined $device and $device == -1){
            $device = undef;
            last;
        } elsif (defined $device){
            last;
        }
    }
    return $device;
}

=item get_subnets(device)

Grab netmask and ip from device interfaces.  Determine device subnets
mathematically based upon the interface information. 

=cut

sub get_subnets {
    my $device = shift;

    my $ip_netmask   = $device->ip_netmask();

    # We need to lock the table, because multiple processes
    # could update the same row when discovering different
    # devices.
    sql_begin(['subnets']);
    foreach my $ip (keys %$ip_netmask){
        next if $ip eq '0.0.0.0';
        # Local Host
        next if $ip =~ /^127\./;

        if (defined $CONFIG{ignore_private_nets} and $CONFIG{ignore_private_nets} and is_private($ip)) {
            print "  Ignoring private address $ip\n" if ($DEBUG);
            next;
        }

        my $netmask = $ip_netmask->{$ip};
        next if $netmask eq '255.255.255.255' or $netmask eq '0.0.0.0';
        my $cidr_subnet = cidr($ip, $netmask);
        
        insert_or_update('subnets', {'net' => $cidr_subnet},
                        {'net' => $cidr_subnet , 'last_discover' => scalar(localtime) }
                        );
        $DEBUG and print "Found subnet $cidr_subnet\n";
    }
    sql_commit();
}

=item store_modules()

Gets all the physical module information using Table Methods in SNMP::Info.

Deletes the old module entries in device_module and puts in new ones.

=cut

sub store_modules {
    my $device = shift;
    my $devip  = $device->{ip};

    print "[$devip]  Fetching Module Information\n";
    my $m_count = 0;

    my $e_index   = $device->e_index();
    if (!defined($e_index)) {
        print "[$devip]   0 Modules.\n";
        return;
    }
    my $e_descr   = $device->e_descr();
    my $e_type    = $device->e_type();
    my $e_parent  = $device->e_parent();
    my $e_name    = $device->e_name();
    my $e_class   = $device->e_class();
    my $e_pos     = $device->e_pos();
    my $e_hwver   = $device->e_hwver();
    my $e_fwver   = $device->e_fwver();
    my $e_swver   = $device->e_swver();
    my $e_model   = $device->e_model();
    my $e_serial  = $device->e_serial();
    my $e_fru     = $device->e_fru();

    sql_begin();
    sql_do(qq/DELETE from device_module where ip = '$devip'/);
    foreach my $key (keys %$e_class) {
        my %store;
        my $type;

        $store{ip}            = $devip;
        $store{index}         = $e_index->{$key};
        $store{description}   = $e_descr->{$key};
        $type = $e_type->{$key};
        # OID translation - SNMP::Info should do this
        #  but versions before 1.06 do not
        if ($type =~ /^[0-9.]+$/) {
            my $trans = SNMP::translateObj($type);
            $type = $trans if defined($trans);
        }
        $store{type}          = $type;
        $store{parent}        = $e_parent->{$key};
        $store{name}          = $e_name->{$key};
        $store{class}         = $e_class->{$key};
        $store{pos}           = $e_pos->{$key};
        $store{hw_ver}        = $e_hwver->{$key};
        $store{fw_ver}        = $e_fwver->{$key};
        $store{sw_ver}        = $e_swver->{$key};
        $store{model}         = $e_model->{$key};
        $store{serial}        = $e_serial->{$key};
        $store{fru}           = $e_fru->{$key};
        $store{last_discover} = 'now';

        insert_or_update('device_module', { 'ip' => $devip,
                                            'index' => $store{index} },
                         \%store );

        $m_count++;
    }
    sql_commit();

    print "[$devip]   $m_count Modules.\n";
}

=item mac_getportmacs() 

Fills the global %PortMAC with MAC addresses of ports already discovered.  
This is to make sure we don't mac-suck existing ports, such as VLANs.

=cut

sub mac_getportmacs {
    print "mac_getportmacs() ..." if $DEBUG;
    
    # I probably could have done this in a join but ...

    my $portmacs = sql_rows('device_port',['mac','ip'],{'mac' => \\'is not null'}); 
    foreach my $row (@$portmacs){
        my $mac = $row->{mac};
        my $ip  = $row->{ip};
        $PortMAC->{$mac}=$ip;
    }
    my $devmacs = sql_rows('device',['mac','ip'],{'mac' => \\'is not null'});
    foreach my $row (@$devmacs){
        my $mac = $row->{mac};
        my $ip  = $row->{ip};
        $PortMAC->{$mac}=$ip;
    }

    print " found ",scalar(keys %$PortMAC), " MACs.\n" if $DEBUG;
}

=item macsuck() 

Walks forwarding table for a specific device. 

Gets mac addresses that are listed in physical ports that do not have a
neighbor listed.   If the device has VLANs, it will walk each VLAN and get the
MAC addresses from there.

=cut

sub macsuck{
    my $hostname = shift;

    my $ip = getip($hostname);

    print "macsuck($hostname) :\n";

    unless (defined $ip){
        print " Name does not resolve with DNS.\n";
        return;
    }

    $ip = root_device($ip);

    # all numeric host name (bad) looks like an IP but fails.
    unless (defined $ip){
        print "  IP not resolved.\n";
        return;
    }

    # Get the device info and its interfaces
    my $dev = sql_hash('device',['*'],{'ip'=>$ip});
    my $ports = sql_rows('device_port',['*'],
        {'ip'=>$ip});

    unless (defined $dev->{ip}) { 
        print "! [$hostname]  Device not found in database.  Try ``netdisco -N -r $hostname''\n";
        return;
    }

    return unless ok_to($dev, $hostname, 'macsuck');

    &load_old_devices unless (defined $OldDevices);
    &mac_getportmacs  unless (defined $PortMAC);

    # Move the ports from an array to a hash, indexed on port name
    my %dbports = ();
    foreach my $p (@$ports) {
        my $port = $p->{port};
        $dbports{$port}=$p;
    }

    # Make the SNMP connection
    my $time1 = time;
    my $device = get_device($hostname) or return;

    my $interfaces = $device->interfaces();
    my $fw_cache = {};

    my $nodes = 0;
    $nodes += walk_fwtable($device,\%dbports,$interfaces,$fw_cache);
    $nodes += macsuck_vlans($device,$hostname,\%dbports,$interfaces,$fw_cache);

    mac_savecache($fw_cache,\%dbports);

    if (!defined($CONFIG{'store_wireless_client'}) || $CONFIG{'store_wireless_client'}) {
        wireless_client_info($device, $ip);
    }

    # Log This
    my $started = localtime($time1);  my $time2 = time;
    insert_or_update('device',{'ip'=> $ip},{'last_macsuck'=>$started});
    print " Saw : ",$nodes, " forwarding table entries.  Took ",$time2-$time1," seconds.\n" if $DEBUG;
    return $nodes;
}

=item macsuck_vlans(...)

For certain Cisco switches you have to connect to each VLAN and get the
forwarding table out of it.  Notably the Catalyst 5k, 6k, and 3500 series

This sub checks to see if the device supports this and then interrogates each VLAN.

Returns number of nodes discovered in forwarding tables.

=cut

sub macsuck_vlans {
    my ($device,$hostname,$dbports,$interfaces,$fw_cache) = @_;

    my $cisco_comm_indexing = $device->cisco_comm_indexing() || 0;
    return 0 unless $cisco_comm_indexing;

    print "[$hostname] Device supports Cisco community string indexing. Connecting to each VLAN:\n";

    my $i_vlan   = $device->i_vlan() || {};
    my $ver      = $device->snmp_ver();
    my $comm     = $device->snmp_comm();
    my $obj      = $device->class();

    my (%vlans, %vlan_names);

    # Get list of VLANs currently in use by ports
    foreach my $iid (keys %$i_vlan){
        my $vlan = $i_vlan->{$iid};
        $vlans{$vlan}++;
    }

    unless (scalar keys %vlans) {
        print "[$hostname] No VLANs found.\n";
        return 0;
    }

    # Get VLAN Names
    my $v_name   = $device->v_name() || {};
    foreach my $vid (keys %$v_name) {
        # HACK : VLAN id comes as 1.142 instead of 142
        my $vlan = $vid;
        $vlan =~ s/^\d+\.//;

        # add to known vlans in case v_name() pulls some that i_vlan() doesn't.
        # This is probably over-kill
        $vlans{$vlan}++;

        $vlan_names{$vlan}=$v_name->{$vid};
    }

    print "[$hostname] VLANS : ",join(',',sort keys %vlans),"\n"  if $DEBUG;

    my $nodes = 0;

    # Create a separate SNMP session to talk to the device
    # for each VLAN.  We update the session using
    # update() to change the community string
    # (or context) to "connect" to each VLAN.
    my %args = get_snmp_args($hostname, $ver, $comm);
    $args{VersionForce} = 1;        # use exactly this version since we know it works
    $args{Class} = $obj;
    my $vlan_device = create_device(%args);

    # For each VLAN, connect and then macsuck
    foreach my $vlan (sort { my $aa=$a; my $bb=$b; $aa=~ s/^\d+\.//;$bb=~ s/^\d+\.//;
                            # Sort by VLAN id
                            $aa <=> $bb
                          }
                     keys %vlans)
    {
        my $vlan_name = $vlan_names{$vlan} || '(Unnamed)';

        if (defined $CONFIG{macsuck_no_vlan} and defined $CONFIG{macsuck_no_vlan}->{$vlan_name}){
            print "[$hostname] VLAN:$vlan_name ($vlan) Skipped by configuration file.\n";
            next;
        }

        # Only macsuck VLAN if in use by port
        #   but check to see if device serves us that list first
        if (scalar keys(%$i_vlan) and !defined $vlans{$vlan}
            and !$CONFIG{macsuck_all_vlans}){
            print "[$hostname] VLAN:$vlan_name ($vlan) Skipped because not in use by a port.\n";
            next;
        }

        unless (defined $vlan_device && $vlan_device != -1){
            print "[$hostname] Could not connect for VLANs!\n";
        }

        print "[$hostname] VLAN:$vlan_name ($vlan) :\n";

        if ($ver == 3) {
            $vlan_device->update(Context => "vlan-$vlan");
        } else {
            $vlan_device->update(Community => $comm . '@' . $vlan);
        }
        $nodes += walk_fwtable($vlan_device,$dbports,$interfaces,$fw_cache);
    }

    return $nodes;
}

=item wireless_client_info

Walks Cisco dot11 client associations, if present, and stores per-client
association information.

=cut

sub wireless_client_info {
    my $device = shift;
    my $ip = shift;

    my $cd11_txrate = $device->cd11_txrate();
    return unless $cd11_txrate and %$cd11_txrate;

    my $cd11_rateset = $device->cd11_rateset();
    my $cd11_uptime = $device->cd11_uptime();
    my $cd11_sigstrength = $device->cd11_sigstrength();
    my $cd11_sigqual = $device->cd11_sigqual();
    my $cd11_mac = $device->cd11_mac();
    my $cd11_port = $device->cd11_port();
    my $cd11_rxpkt = $device->cd11_rxpkt();
    my $cd11_txpkt = $device->cd11_txpkt();
    my $cd11_rxbyte = $device->cd11_rxbyte();
    my $cd11_txbyte = $device->cd11_txbyte();

    sql_begin();
    foreach my $key (keys %$cd11_txrate) {
        my $txrates = $cd11_txrate->{$key};
        my $rates = $cd11_rateset->{$key};
        my %store = ();
        $store{mac} = $cd11_mac->{$key};
        next unless defined($store{mac}); # There can sometimes be more rows in the txrate and
                                          # rateset columns than all others, so avoid getting NULLs
        my $txrate = defined $txrates->[$#$txrates] ? int($txrates->[$#$txrates]) : undef;
        my $maxrate = defined $rates->[$#$rates] ? int($rates->[$#$rates]) : undef;
        $store{txrate} = $txrate;
        $store{maxrate} = $maxrate;
        $store{uptime} = $cd11_uptime->{$key};
        $store{sigstrength} = $cd11_sigstrength->{$key};
        $store{sigqual} = $cd11_sigqual->{$key};
        $store{rxpkt} = $cd11_rxpkt->{$key};
        $store{txpkt} = $cd11_txpkt->{$key};
        $store{rxbyte} = $cd11_rxbyte->{$key};
        $store{txbyte} = $cd11_txbyte->{$key};
        $store{time_last} = scalar(localtime);
        insert_or_update('node_wireless', {'mac' => $cd11_mac->{$key}}, \%store);
    }
}

=item mac_savecache({},{})

Does two things  : 

1. Checks for detected uplinks, warns of such and removes nodes on these uplinks from additions list

2. Stores the found forwarding table entries to the database.

=cut

sub mac_savecache {
    my $fw_cache = shift;
    my $dbports  = shift;

    # No entries to add?
    return unless scalar keys %$fw_cache;

    # Check for detected uplinks
    foreach my $ip (keys %$fw_cache){
        foreach my $port (sort {sort_port} keys %{$fw_cache->{$ip}}){
            my $remote_ip = $dbports->{$port}->{remote_ip} || '';

            # Check for detected uplink
            next unless $remote_ip eq 'uplink';
            print "[$ip]  Port $port detected as uplink, topology broken.  Not adding nodes from this port.\n";
            delete $fw_cache->{$ip}->{$port};
        }
    }

    sql_begin(['node']);
    foreach my $ip (keys %$fw_cache){
        foreach my $port (sort {sort_port} keys %{$fw_cache->{$ip}}){
            my $macs = $fw_cache->{$ip}->{$port};
            print "  $ip -> $port : ", scalar keys %$macs, " nodes\n" if $DEBUG;
            foreach my $mac (keys %$macs){
                add_node($mac,$ip,$port); 
            }
        }
    }
    sql_commit();

}


=item macwalk() 

Grabs all the devices out of the database. 
Runs macsuck() on each device that has layer2 capabilites.

=cut

sub macwalk {
    $start_time = time;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/mac",1);
    print "Grabbing Mac Addresses from all Layer 2 Devices (" . localtime() . ")...\n";

    # Get our old devices, IP->Layer mapping
    &load_old_devices;
    
    # Get mac addresses of all the ports 
    &mac_getportmacs;

    $controller = $$;
    sql_begin();
    foreach my $device (keys %$OldDevices){
        next unless ok_to($device, $device, 'macsuck');
        queue_process($device, 'macsuck') if (has_layer($OldDevices->{$device},2));
    }
    sql_commit();
    dispatcher('macsuck', \&macsuck);

    sql_vacuum('node','print'=>1);

    send_monitor_email();

    &end;
}

=item send_monitor_email()

If there is an email address configured in netdisco.conf under
node_monitor_email, look for any rows in the node_monitor table
that are being monitored and if the mac address has arrived or
moved, send the appropriate email.  This function only works
immediately after macsuck; if another macsuck happens in between
this will not detect the arrival.  Therefore, this function
is only ever called from the end of F<macwalk>.

=cut

sub send_monitor_email {
    my $node_monitor_email = $CONFIG{node_monitor_email};
    if (defined $node_monitor_email) {
        # time_recent == time_last gets us to trigger exactly when the
        # device [re-]arrives in the network.
        my $alerts = sql_rows('node_monitor nm, node n, device d, device_port dp',
                [ 'nm.why', 'nm.cc', 'nm.date',
                  'n.mac', 'n.switch', 'n.port',
                  'd.name', 'd.location',
                  'dp.name as portname' ],
                { 'nm.mac' => \'n.mac', 'nm.active' => 't',
                  'd.ip' => \'n.switch',
                  'dp.ip' => \'n.switch', 'dp.port' => \'n.port',
                  'd.last_macsuck' => \\'<= n.time_last',
                  'n.time_recent' => \'n.time_last' } );
        foreach my $alert (@$alerts) {
            my $body = <<"end_body";
........ n e t d i s c o .........
  Node    : $alert->{mac} ($alert->{why})
  When    : $alert->{date}
  Switch  : $alert->{name} ($alert->{switch})
  Port    : $alert->{port} ($alert->{portname})
  Location: $alert->{location}

end_body
            my $to = $node_monitor_email;
            if ($alert->{cc}) {
                $to .= "," . $alert->{cc};
            }
            &mail($to,"Saw mac $alert->{mac} ($alert->{why}) on $alert->{name} $alert->{port}",$body);
        }
    }
}

=item set_status()

Sets $0 to a status string.  Use sprintf-style arguments.
=cut

sub set_status($@) {
    my($fmt) = shift;
    $0 = "netdisco: " . sprintf($fmt, @_);
}

=item parallel_init()

Initializes parallelization with the maximum number of simultaneously running processes
set in configuration file. Creates a dummy SNMP::Info object to load MIBs only once for each child.
Disconnects the database handle so that it's not held open across a fork.

=cut

sub parallel_init {
    $nprocs = $CONFIG{max_procs} || 1;
    my $pm = undef;

    if ($nprocs > 1) {
        my ($ret) = tryuse('Parallel::ForkManager');
        if ($$ret[0] == 0) {
            print "! Parallel mode disabled: $$ret[1]\n";
            $nprocs = 1;
        }
    }
    if ($nprocs < 2) {
        $nprocs = 1;
        return undef;
    }
    $pm = new Parallel::ForkManager($nprocs);
    print "Parallel mode enabled, forking $nprocs processes.\n";
    #HACK to prevent SNMP::Info load mib-init in each forked process
    my $dummy = new SNMP::Info( DestHost    => 'localhost',
                                Version     => 1,
                                AutoSpecify => 0,
                                Debug       => 0,);
    sql_disconnect();   # parent shouldn't have a database handle
    set_status("parent forking %d children", $nprocs);
    return $pm;
}

=item dispatcher(action, subroutine)

Multi-process dispatcher that handles the "standard" case of
multiple macsuck/arpnip/nbtstat.  It uses Parallel::ForkManager
in a slightly unusual way, in that it forks off long-lived
worker children that service the queue themselves, similar to
Apache.

=cut

sub dispatcher {
    my ($action, $sub) = @_;
    my $pm = parallel_init();
    my $timeout = $CONFIG{$action . "_timeout"} || $CONFIG{timeout} || 90;

    # The discovery process can result in adding jobs
    # to the queue, so if we're discovering, loop until
    # $njobs == 0.
    do {
        my $njobs = sql_scalar('process',['count(*)'],
                    { controller => $controller,
                      action => $action,
                      status => 'queued' });
        return if ($njobs == 0);

        $njobs = $nprocs if ($njobs > $nprocs);
        # Disconnect from server before forking.
        sql_disconnect();
        # Fork off workers.  If we're not forking, parallel_init()
        #  set nprocs to 1.
        for (my $i = 0; $i < $njobs; $i++) {
            $pm->start and next if defined($pm);
            # First make sure we can get a database connection.
            # A given worker gets and holds a database connection
            # for its life, so that failing to get a connection
            # (e.g., because resource limits are too low) doesn't
            # lose work.
            eval {
                # Don't allow DBI to print its errors using warn
                local $SIG{__WARN__} = sub {};
                dbh();
            };
            if ($@) {
                printf("Worker #%d failed to get a database connection: %s", $i + 1, $@);
                if ($i == 0) {
                    print "Work may not get done.\n";
                } else {
                    print "Work should get done anyway.\n";
                }
                exit;
            }
            while (1) {
                set_status("worker %d looking for %s job", $i + 1, $action);
                # Limit how many rows get locked, use offset to try and prevent
                # collision.  Don't use ORDER BY as we want unordered data to
                # spread requests across network.
                sql_begin();
                my $offset = $i;
                my $sql = qq/LIMIT 1 OFFSET $offset FOR UPDATE/;
                my $dev = sql_hash('process',['controller','action','device'],
                        {'controller' => $controller,
                         'action' => $action,
                         'status' => 'queued'}, 0, $sql);
                if (!defined($dev)) {
                    sql_commit();
                    # We may get no rows because FOR UPDATE is applied after
                    # LIMIT 1, so check to see if there are still jobs before
                    # ending.  This is more load on DB but prevents blocking
                    # other workers on fast running jobs like nbtstat
                    my $njobs = sql_scalar('process',['count(*)'],
                                { controller => $controller,
                                action => $action,
                                status => 'queued' });
                    last if ($njobs == 0);
                    $offset = 0 if ($njobs < $offset);
                    next;
                }
                insert_or_update('process', $dev, { 'status' => 'running' });
                sql_commit();
                set_status("%s %s", $action, $dev->{device});
                my $count = 0;
                eval {
                    alarm($timeout);
                    $count = &$sub($dev->{device});
                    alarm(0);
                };

                my $status = 'done';
                if ($@) {
                    if ($@ =~ /timeout/){
                        $status = 'timedout';
                        print "[$dev->{device}]  ! timed out in $action ($timeout sec)\n";
                    } else {
                        $status = 'error';
                        print "[$dev->{device}] !! $@\n";
                    }
                    # If we timed out or errored in the middle of a
                    # transaction, roll it back.
                    sql_rollback();
                }
                $count ||= 0;
                insert_or_update('process', $dev, { 'status' => $status, 'count' => $count });
            }
            $pm->finish if defined($pm);
        }
        if (defined($pm)) {
            set_status("parent waiting for children to exit");
            $pm->wait_all_children;
            print "Parallel mode completed.\n";
        }
    } until ($action ne 'discover');
}

=item port_control(switch,port,direction)

=cut

sub port_control {
    my ($switch,$port,$direction,$job) = @_;
    my $vlan = $job->{subaction};
    my $cmd  = $job->{action};

    unless (defined $switch and defined $port and defined $direction){
        print "Usage : port_control(switch,port,up/down)\n";
        return undef;
    }
    unless (defined $CONFIG{community_rw} and scalar @{$CONFIG{community_rw}}){
        print "No read-write community string has been set. Please add a community_rw setting to the Config file.\n";
        return undef;
    } 

    # Check for device in DB
    my $ip = getip($switch);
    $ip    = root_device($ip);

    # Get dev info from database
    my $db_dev = sql_hash('device',['*'],{'ip' => $ip}) if defined $ip;

    unless (defined $ip and defined $db_dev){
        print "Device $switch not found in netdisco.  Please discover device and try again.\n";
        return undef;
    } 
    
    # Check for port
    my $db_port = sql_hash('device_port',['*'],{ 'ip'=>$ip, 'port'=>$port });

    # Categorize this port
    my $is_phone      = (defined $db_port->{remote_type} and $db_port->{remote_type} =~ /ip.phone/i) ? 1 : 0;
    my $is_vlan       = (defined $db_port->{type} and $db_port->{type} =~ /^(53|propVirtual|l2vlan|l3ipvlan|135|136|137)$/i) ? 1 : 0;
       $is_vlan       = $is_vlan || (defined $db_port->{port} and $db_port->{port} =~ /vlan/i);
       $is_vlan       = $is_vlan || (defined $db_port->{name} and $db_port->{name} =~ /vlan/i);
    my $allow_phones  = (defined $CONFIG{portctl_nophones} and $CONFIG{portctl_nophones}) ? 0 : 1;
    my $allow_uplinks = (defined $CONFIG{portctl_uplinks} and $CONFIG{portctl_uplinks}) ? 1 : 0;
    my $allow_vlans   = (defined $CONFIG{portctl_vlans} and $CONFIG{portctl_vlans}) ? 1 : 0;
    my $change_vlans  = (defined $CONFIG{vlanctl} and $CONFIG{vlanctl} ) ? 1 : 0;

    unless (defined $db_port){
        print "Port : $port not found in database for device $switch\n";
        return undef;
    }

    # Check if uplink port
    if (defined $db_port->{remote_ip} and !$is_phone and !$allow_uplinks){
        print "Port : $port is an uplink port. Control from netdisco not allowed.\n";
        return undef;
    } 
    
    # Check if Phone
    if ($is_phone and !$allow_phones){
        print "Port : $port has an IP Phone connected to it.  Netdisco configured to not allow its change.\n";
        return undef;
    }

    # Check if is VLAN
    if ( ($is_vlan and !$allow_vlans) or ($is_vlan and $cmd eq 'vlan') ){
        print "Port : $port is a VLAN interface.  Netdisco Configured to not allow its change.\n";
        return undef;
    }

    if ( $cmd eq 'vlan' and !$change_vlans) { 
        print "Netdisco configured to not allow the change of VLANs. Set vlanctl=true in netdisco.conf\n";
        return undef;
    }

    # SNMP connect
    my $snmp_ver = $db_dev->{snmp_ver} || $CONFIG{snmpver} || 2;
    my $device = get_device_rw($ip,$snmp_ver);

    unless (defined $device){
        print "Could not connect to device with read-write community string.\n";
        return undef; 
    }
    
    my $interfaces = $device->interfaces();
    my %rev_if     = reverse %$interfaces;
    my $iid        = $rev_if{$port};

    # Switch the port
    my $rv = undef;
    if ($cmd eq 'portcontrol') {
        $rv = $device->set_i_up_admin(lc($direction),$iid);
    }
    if ($cmd eq 'vlan') {
        $rv = $device->set_i_vlan($vlan,$iid);
    }
    
    unless (defined $rv){
        my $error = $device->error() || '';
        print "Set failed. $error\n";
        return undef;
    }

    # Mark down change in netdisco
    if ($cmd eq 'portcontrol') {
        insert_or_update('device_port', {'ip'=>$ip,'port'=>$port} , {'up_admin'=>$direction});
        print "Succesfully set Port:$port $direction on $switch\n";
    }
    if ($cmd eq 'vlan') {
        insert_or_update('device_port', {'ip'=>$ip,'port'=>$port} , {'vlan'=>$vlan});
        print "Succesfully change Port:$port to vlan $vlan on $switch\n";
    }

    return 1;
}

=item port_switch({})

Used to shut ports on and off and to change VLANs.

=cut

sub port_switch {
    my $job = shift;

    # Not sent from front-end via admin daemon
    unless (defined $job){
        
    }
    my $user   = $job->{username};
    my $userip = $job->{userip};
    my $ip     = getip($job->{device});
    my $port   = $job->{port};
    my $cmd    = $job->{action};
    my $vlan   = $job->{subaction};
    my ($dir,$reason) = $cmd eq 'portcontrol' ? split('-',$job->{subaction}) :
                        $cmd eq 'vlan'    ? ( 'vlan', $vlan ) : 
                        ('','');
    my $long_reason = '';
    if (defined $reason) {
        $long_reason = $netdisco::PORT_CONTROL_REASONS{$reason}->[0];
    }
    my $log    = $job->{log};
    my $dns    = &hostname($ip);
   
    print "port_switch() - $user @ $userip. c:$cmd d:$dir r:$reason i:$ip d:$dns p:$port l:$log\n" if $DEBUG;
    # Switch the Port
    my $rv = port_control($ip,$port,$dir,$job); 

    if (!defined $rv){
        print "\n[FAILED].\n";
        $log = "[FAILED] - See admin queue job log. \n $log";
        return 1;
    }

    my $action = $dir;
    $action = 'enable'  if $dir eq 'up';
    $action = 'disable' if $dir eq 'down';

    # Send E-Mail to Abuse
    my $portctl_email = $CONFIG{portctl_email};
    if (defined $portctl_email){
        print "Sending notification to $portctl_email\n";
        my $body = '';
        $body = <<"end_portctl" if $cmd eq 'portcontrol';
........ n e t d i s c o .........
  Device : $dns ($ip) 
  Port   : $port
  Action : $action
  User   : $user \@ $userip 
  Reason : [$reason] - $long_reason
  Log    : $log

end_portctl
        $body = <<"end_body" if $cmd eq 'vlan';
........ n e t d i s c o .........
  Device : $dns ($ip) 
  Port   : $port
  Action : Switch VLAN
  User   : $user \@ $userip 
  VLAN   : $vlan
  Log    : $log

end_body

        &mail($portctl_email,"port $action $dns($ip)/$port",$body);
    }
    # Log
    insert_or_update('device_port_log', {},
                     {'ip'=>$ip,'port'=>$port,'log'=>$log,'userip'=>$userip,
                      'username'=>$user,'action'=>$action, 'reason' => $reason }
                    ); 

    return 0;
}

=item location_set({})

Used to change sysLocation string.

=cut

sub location_set {
    my $job = shift;

    # Not sent from front-end via admin daemon
    unless (defined $job){
        
    }
    my $user     = $job->{username};
    my $userip   = $job->{userip};
    my $ip       = getip($job->{device});
    my $cmd      = $job->{action};
    my $location = $job->{subaction};
    my $log      = $job->{log};
    my $dns      = &hostname($ip);
    my $rv	 = 1;
   
    print "location_set() - $user @ $userip. c:$cmd l:$location i:$ip d:$dns l:$log\n" if $DEBUG;

    unless (defined $CONFIG{community_rw} and scalar @{$CONFIG{community_rw}}){
        print "No read-write community string has been set. Please add a community_rw setting to the Config file.\n";
        goto error;
    }

    # Check for device in DB
    $ip    = root_device($ip);

    # Get dev info from database
    my $db_dev = sql_hash('device',['*'],{'ip' => $ip}) if defined $ip;

    unless (defined $ip and defined $db_dev){
        print "Device $job->{device} not found in netdisco.  Please discover device and try again.\n";
        goto error;
    } 
    
    # SNMP connect
    my $snmp_ver = $db_dev->{snmp_ver} || $CONFIG{snmpver} || 2;
    my $device = get_device_rw($ip,$snmp_ver);

    unless (defined $device){
        print "Could not connect to device with read-write community string.\n";
        goto error; 
    }

    $rv = $device->set_location($location);
    if (!defined($rv)){
	my $error = $device->error() || '';
        print "Set failed. $error\n";
error:
        print "\n[FAILED].\n";
        $log = "[FAILED] - See admin queue job log. \n $log";
        return 1;
    }
    insert_or_update('device', {'ip'=>$ip} , {'location'=>$location});
    print "Succesfully set location:$location on $ip\n";

    # Log
    insert_or_update('device_port_log', {},
                     {'ip'=>$ip,'port'=>'','log'=>$log,'userip'=>$userip,
                      'username'=>$user,'action'=>$cmd,'reason'=>$location}
                    ); 

    return 0;
}

=item store_device() 

Calls all the global methods and sends the results off to the database

=cut

sub store_device {
    my $device = shift;

    print "[$device->{ip}]  Fetching Device Info\n";

    # Deal w/ devices with multiple IP address like most routers
    my $foundip = $device->{ip};
    my $devip = device_root($device);
    $device->{ip} = $devip;

    if ($devip ne $foundip) {
        print "[$devip]  Using $devip instead of $foundip \n" if $DEBUG;

        # Set device name to root, not alias
        my $new_dns = &hostname($devip);
        $device->{dns} = $new_dns if (defined $new_dns and length($new_dns));
    }

    my $ip_index   = $device->ip_index();
    my $interfaces = $device->interfaces();
    my $ip_netmask = $device->ip_netmask();

    sql_begin();
    
    # Remove all alias IP addresses
    sql_do(qq/DELETE from device_ip where ip = '$devip'/);

    # Store all our IPs
    foreach my $ip (keys %$ip_index){
        next if $ip eq '0.0.0.0';
        # Local Host
        next if $ip =~ /^127\.0\.0\./;

        if (defined $CONFIG{ignore_private_nets} and $CONFIG{ignore_private_nets} and is_private($ip)) {
            print "[$devip]  Ignoring private address $ip\n" if ($DEBUG);
            next;
        }

        my $iid  = $ip_index->{$ip};
        my $port = $interfaces->{$iid}; 
        my $dns  = &hostname($ip);
        my $netmask = $ip_netmask->{$ip} || '0.0.0.0';
        my $subnet  = $netmask eq '0.0.0.0' ? undef : cidr($ip, $netmask);

        insert_or_update('device_ip', {'ip' => $devip,  'alias' => $ip},
                        {'ip' => $devip , 'alias' => $ip, 'port' => $port,
                         'subnet' => $subnet, 'dns' => $dns }
                        );
        $DEBUG and print "[$devip]  Adding $ip to device_ip\n";
        $Aliases->{$ip} = $devip;
        
        # Mark alias down
        $device->{_alias}->{$ip}++;
    }
    sql_commit();

    # VTP Management Domain -- assume only one.
    my $vtpdomains = $device->vtp_d_name();
    my $vtpdomain;
    if (defined $vtpdomains and scalar(values(%$vtpdomains))) {
        $vtpdomain = (values(%$vtpdomains))[-1];
    }

    my %store = ();

    $store{ip}          = $device->{ip};
    $store{dns}         = $device->{dns};
    $store{snmp_ver}    = $device->snmp_ver();
    $store{snmp_comm}   = $device->snmp_comm();
    $store{snmp_class}  = $device->class();
    $store{description} = $device->description();
    $store{uptime}      = $device->uptime();
    $store{contact}     = $device->contact();
    $store{name}        = $device->name();
    $store{location}    = $device->location();
    $store{layers}      = $device->layers();
    $store{ports}       = $device->ports();
    $store{mac}         = $device->mac();
    $store{serial}      = $device->serial();
    $store{model}       = $device->model();
    $store{ps1_type}    = $device->ps1_type();
    $store{ps2_type}    = $device->ps2_type();
    $store{ps1_status}  = $device->ps1_status();
    $store{ps2_status}  = $device->ps2_status();
    $store{fan}         = $device->fan();
    $store{slots}       = $device->slots();
    $store{vendor}      = $device->vendor();
    $store{os}          = $device->os();
    $store{os_ver}      = $device->os_ver();
    $store{vtp_domain}  = $vtpdomain;
    #$store{log}         = $device->log();
    $store{last_discover} = localtime;
    
    insert_or_update('device', {'ip' => $device->{ip} },
                    \%store);
}

=item store_interfaces() 

Gets all the interface information using Table Methods in SNMP::Info.  

Deletes the old interface entries in device_port and puts in new ones.

=cut

sub store_interfaces { 
    my $device = shift;
    
    my $ip = $device->{ip};
    print "[$ip]  Fetching Interface Information\n";
    my $i_count        = 0;
    my $interfaces     = $device->interfaces();
    my $i_type         = $device->i_type();
    my $i_ignore       = $device->i_ignore();
    my $i_descr        = $device->i_description();
    my $i_mtu          = $device->i_mtu();
    my $i_speed        = $device->i_speed();
    my $i_mac          = $device->i_mac();
    my $i_up           = $device->i_up();
    my $i_up_admin     = $device->i_up_admin();
    my $i_name         = $device->i_name();
    my $i_duplex       = $device->i_duplex();
    my $i_duplex_admin = $device->i_duplex_admin();
    my $i_stp_state    = $device->i_stp_state();
    my $i_vlan         = $device->i_vlan();
    my $i_pvid         = $device->i_pvid();
    my $i_lastchange   = $device->i_lastchange();

    delete $device->{_uptime}; # Clear cached value of uptime, we need the actual current value here
    my $dev_uptime = $device->uptime();
    my $uptime_has_wrapped = 0;
    my $calc_uptime;

    sql_begin();

    foreach my $lastchange (values %$i_lastchange) {
        if ($lastchange > $dev_uptime) {
            $uptime_has_wrapped++;
        }
    }

    if ($uptime_has_wrapped) {
        printf("[%s]    Device uptime counter seems to have wrapped. Assuming one wrap, applying corrections.\n", $ip);
        $calc_uptime = $dev_uptime + 2**32;
        insert_or_update('device', { 'ip' => $ip }, { 'uptime' => $calc_uptime } );
    }

    # Delete old interface information (for dynamic,vlan...)
    sql_do(qq/DELETE from device_port where ip = '$ip'/);

    foreach my $if (keys %$interfaces) {
        $i_count++;
        my %store = ();
        my $port = $interfaces->{$if};
        unless (defined $port and length($port)) {
            $DEBUG and print "  Ignoring $if (no port mapping)\n";
            next;
        }
        if (defined $CONFIG{ignore_interfaces} and
            (scalar (grep {$port =~ m/$_/} @{$CONFIG{ignore_interfaces}}) > 0) ) {
            $DEBUG and print "  Ignoring $if ($port) (requested in configuration)\n";
            next;
        }
        $store{type}  = $i_type->{$if};
        if(exists $i_ignore->{$if}) {
            $DEBUG and print "  Ignoring $if ($port) ($store{type})\n";
            next;
        }
        $store{ip}           = $ip;
        $store{port}         = $port;
        $store{descr}        = $i_descr->{$if};
        $store{up}           = $i_up->{$if};
        $store{up_admin}     = $i_up_admin->{$if};
        $store{mac}          = $i_mac->{$if};
        $store{speed}        = $i_speed->{$if};
        $store{mtu}          = $i_mtu->{$if};
        $store{name}         = $i_name->{$if};
        $store{duplex}       = $i_duplex->{$if};
        $store{duplex_admin} = $i_duplex_admin->{$if};
        $store{stp}          = $i_stp_state->{$if};
        $store{vlan}         = $i_vlan->{$if};
        $store{pvid}         = $i_pvid->{$if};
        $store{lastchange}   = $i_lastchange->{$if};

        my $lc = $store{lastchange};
        if ( $uptime_has_wrapped and defined $lc ) {
            if ( $lc < $dev_uptime ) { # Ambiguous: lastchange could be sysUptime before or after wrapping...
                if ( $dev_uptime > 30000 and $lc < 30000 ) {
                    # Uptime wrap was more than 5 minutes ago but lastchange value was within 5 minutes after boot or wrap
                    # -> assume that lastchange was directly after boot, so don't change.
                } else {
                    # Uptime wrap was less than 5 minutes ago or lastchange was more than 5 minutes after boot or wrap
                    # -> to be on the safe side, assume that lastchange was after counter wrap, so add correction.
                    $store{lastchange} = $lc + 2**32;
                    printf("[%s]     Correcting LastChange for %s, assuming it's after sysUptime wrap\n", $ip, $port) if $DEBUG;
                }
            }
        }

        insert_or_update('device_port', { 'ip' => $ip, 'port' => $store{port} }, 
                         \%store );        

    }
    sql_commit();
    print "[$ip]   $i_count Interfaces.\n";

    # Get SSIDs for wireless interfaces
    my $ssidlist = $device->i_ssidlist();
    my ($ssidbcast, $channel, $power) = (undef, undef, undef);
    if (defined($ssidlist)) {
        $ssidbcast = $device->i_ssidbcast();
        $channel = $device->i_80211channel();
        $power = $device->dot11_cur_tx_pwr_mw();
    }

    sql_begin();

    sql_do(qq/DELETE from device_port_ssid where ip = '$ip'/);

    foreach my $ssididx (keys %$ssidlist) {
        my $if = $ssididx;
        $if =~ s/\.\d+$//;
        my %store = ();
        my $port = $interfaces->{$if};
        unless (defined $port and length($port)) {
            $DEBUG and print "\n  Ignoring $if (no port mapping)\n";
            next;
        }
        $store{ip}           = $ip;
        $store{port}         = $port;
        $store{ssid}         = $ssidlist->{$ssididx};
        $store{broadcast}    = $ssidbcast->{$ssididx};
        insert_or_update('device_port_ssid', { 'ip' => $ip, 'port' => $store{port}, 'ssid' => $store{ssid} }, 
                         \%store );
    }
    foreach my $channelidx (keys %$channel) {
        my $if = $channelidx;
        my %store = ();
        my $port = $interfaces->{$if};
        unless (defined $port and length($port)) {
            $DEBUG and print "\n  Ignoring $if (no port mapping)\n";
            next;
        }
        $store{ip}           = $ip;
        $store{port}         = $port;
        $store{channel}      = $channel->{$if};
        $store{power}        = $power->{$if};
        insert_or_update('device_port_wireless', { 'ip' => $ip, 'port' => $store{port} },
                         \%store );
    }

    sql_commit();
}

=item store_vlans()

Gets all the VLAN information using Table Methods in SNMP::Info.  

Deletes the old VLAN entries in device_port_vlan and puts in new ones.

=cut

sub store_vlans {
    my $device = shift;
    
    my $ip = $device->{ip};
    print "[$ip]  Fetching VLAN Information\n";
    my $v_count = 0;

    my $i_vlan = $device->i_vlan();
    my $i_vlan_membership = $device->i_vlan_membership();
    my $i_vlan_type = $device->i_vlan_type();
    my $interfaces = $device->interfaces();

    my %v_seen = ();
    sql_begin();

    my $deleted_vlan_ports = sql_do(qq/DELETE FROM device_port_vlan WHERE ip = '$ip'/);
    $deleted_vlan_ports = 0 if $deleted_vlan_ports eq '0E0';
    print "[$ip]   Scrubbing VLANs from device_port_vlan table... $deleted_vlan_ports removed\n";

    foreach my $if (keys %$i_vlan_membership) {
        my $port = $interfaces->{$if};
        my $vlantype = $i_vlan_type->{$if};
        next unless defined($port);
        $v_count++;
        foreach my $vlan (@{$i_vlan_membership->{$if}}) {
            $v_seen{$vlan} = 1;
            my %store = ();
            my $native = (defined($i_vlan->{$if}) && ($vlan eq $i_vlan->{$if})) ? "t" : "f";
            $store{ip} = $ip;
            $store{port} = $port;
            $store{vlan} = $vlan;
            $store{native} = $native;
            $store{vlantype} = $vlantype;
            $store{last_discover} = 'now';

            insert_or_update('device_port_vlan', {ip => $ip,
                port => $port, vlan => $vlan}, \%store);
        }
    }

    my $deleted_vlans = sql_do(qq/DELETE FROM device_vlan WHERE ip = '$ip'/);
    $deleted_vlans = 0 if $deleted_vlans eq '0E0';
    print "[$ip]   Scrubbing VLANs from device_vlan table... $deleted_vlans removed\n";

    my $v_ncount = 0;
    my $v_name = $device->v_name();
    my $v_index = $device->v_index();
    my %v_nseen = ();
    foreach my $idx (keys %$v_name) {
        $v_ncount++;
        my %store = ();
        $store{ip} = $ip;
        my($vlan) = $v_index->{$idx};
        $store{vlan} = $vlan;
        $store{description} = $v_name->{$idx};
        $store{last_discover} = 'now';
        insert_or_update('device_vlan', {ip => $ip,
            vlan => $vlan}, \%store);

        $v_nseen{$vlan} = 1;
    }
    foreach my $vlan (keys %v_seen) {
        next if $v_nseen{$vlan};
        my %store = ();
        $store{ip} = $ip;
        $store{vlan} = $vlan;
        $store{description} = sprintf("VLAN %d", $vlan);;
        $store{last_discover} = 'now';
        insert_or_update('device_vlan', {ip => $ip,
            vlan => $vlan}, \%store);
    }

    sql_commit();
    print "[$ip]   $v_count VLAN Interfaces, $v_ncount names.\n";
}

=item store_power()

Gets all the Power-over-Ethernet information using Table Methods in SNMP::Info.  

Deletes the old PoE entries in device_power and device_port_power and puts in new ones.

=cut

sub store_power {
    my $device = shift;
    
    my $ip = $device->{ip};
    print "[$ip]  Fetching Power Information\n";
    my $p_count = 0;
    my $pp_count = 0;

    my $p_watts    = $device->peth_power_watts();
    if (!defined($p_watts)) {
        print "[$ip]   0 Power Modules\n";
        return;
    }
    my $p_status   = $device->peth_power_status();

    my $p_admin    = $device->peth_port_admin();
    my $p_pstatus  = $device->peth_port_status();
    my $p_class    = $device->peth_port_class();
    my $p_power    = $device->peth_port_power();
    my $p_ifindex  = $device->peth_port_ifindex();
    my $interfaces = $device->interfaces();

    sql_begin();
    sql_do(qq/DELETE from device_power where ip = '$ip'/);
    foreach my $module (keys %$p_watts) {
        my %store = ();
        $p_count++;
        $store{ip} = $ip;
        $store{module} = $module;
        $store{power} = $p_watts->{$module};
        $store{status} = $p_status->{$module};
        insert_or_update('device_power', {ip => $ip,
            module => $module}, \%store);
    }
    sql_do(qq/DELETE from device_port_power where ip = '$ip'/);
    foreach my $port (keys %$p_ifindex) {
        my %store = ();
        my $portname = $interfaces->{$p_ifindex->{$port}};
        next unless $portname;
        $pp_count++;
        my ($module) = split(/\./, $port);
        $store{ip} = $ip;
        $store{port} = $portname;
        $store{module} = $module;
        $store{admin} = $p_admin->{$port};
        $store{status} = $p_pstatus->{$port};
        $store{class} = $p_class->{$port};
        $store{power} = $p_power->{$port};
        insert_or_update('device_port_power', {ip => $ip,
            port => $portname}, \%store);
    }
    sql_commit();
    print "[$ip]   $p_count Power Modules, $pp_count Power-Capable Ports\n";
}

=item walk_fwtable()  

Walks the Forwarding table from the C<BRIDGE-MIB>
for the given device, and then adds MAC addresses to the C<node> table.
Returns the number of entries fetched.

=cut

sub walk_fwtable {
    my ($device,$dbports,$interfaces,$fw_cache) = @_;

    my $ip = $device->{ip};
    my $fw_mac     = $device->fw_mac();
    my $fw_port    = $device->fw_port();
    my $bp_index   = $device->bp_index();
    my $nodes = 0;

    # To map the port in the forwarding table to the 
    # physical device port we have this triple indirection:
    #      fw_port -> bp_index -> interfaces
    
    foreach my $fw_index (keys %$fw_mac){    
        my $mac    = $fw_mac->{$fw_index};
        my $bp_id  = $fw_port->{$fw_index};

        $nodes++;

        unless (defined $bp_id) {
            print "  $mac: $fw_index has no fw_port mapping.  Skipping\n"
                if $DEBUG;
            next;
        }

        my $iid    = $bp_index->{$bp_id};

        unless (defined $iid) {
            print "  $mac: Port $bp_id has no bp_index mapping. Skipping\n"
                if $DEBUG;
            next;
        }

        my $port  = $interfaces->{$iid};

        unless (defined $port) {
            print "  $mac: SNMP iid $iid has no physical port matching. Skipping.\n"
                if $DEBUG;
            next;
        }

        unless (defined $dbports->{$port}){
            print "  $mac: Port ($port) is not in database.  Skipped.\n"
                if $DEBUG;
            next;
        }

        # Check to see if the port is connected to another device,
        #   and if we have that device in the DB.  

        #If we dont see the device in the db, but there is a neighbor, then we capture anyways,
        #   since we want all the macs at the other end. 

        my $remote_ip = $dbports->{$port}->{remote_ip};
        if (defined $remote_ip) {
            if (defined $OldDevices->{$remote_ip} or defined $Aliases->{$remote_ip}) {
                my $ip = $Aliases->{$remote_ip} || $remote_ip;
                print "  $mac: Port $port has neighbor: $ip. Skipped.\n" if $DEBUG;
                next;
            } elsif ($remote_ip eq 'uplink') {
                print "  $mac: Port $port is detected uplink. Skipped.\n" if $DEBUG;
                next;
            } else {
                # Can be edge of network, but that would be a L3 device.
                print "  $mac: Port $port has neighbor: $remote_ip, but not in Netdisco. Included.\n" if $DEBUG;
            } 
        }

        # Check if Port Channel
        if ($port =~ /port.channel/i) {
            print "  Port ($port) is a Port Channel Interface.  Skipped.\n" if $DEBUG;
            next;
        }
        
        # Check if MAC is a switch port
        if (defined $PortMAC->{$mac}) {
            my $switch_ip = $PortMAC->{$mac};
            if ($ip eq $switch_ip){
                print "  $mac: Port on this switch.  Skipped.\n" if $DEBUG;
                next;
            } 

            # TODO: This is an uplink port, mark here and have another process
            #        add a loopback if no topo info is there. 
            #        Also need some sort of process to show all the loopbacks
            
            # Mark port as uplink
            $dbports->{$port}->{remote_ip}='uplink';
    
            my $bleed = $CONFIG{macsuck_bleed} || 0;
            print "  $mac: Port $port -> Device $switch_ip. " if $DEBUG;

            if ($bleed) {
                print "Included.\n" if $DEBUG;
            } else {
                print "Skipped.\n" if $DEBUG;
                next;  
            }
        }

        # Check for Multicast MACs
        if ($mac =~ /^([0-9a-f]{2}):/i and ($1 =~ /.(1|3|5|7|9|b|d|f)/i)){
            print "  $mac:  MULTICAST\n" if $DEBUG;
            next;
        }

        next if $mac eq '00:00:00:00:00:00';
        next if uc($mac) eq 'FF:FF:FF:FF:FF:FF'; 

        if ($DEBUG) { 
            print "  $mac: $bp_id -> $iid -> $port\n";
        }
        
        $fw_cache->{$ip}->{$port}->{$mac}++;
    }

    return $nodes;
}

=back

=head2 NetBIOS Functions

=over

=item nbtstat(host) 

Connects to node and gets NetBIOS information. Then adds entries to node_nbt table.

Returns whether a node is answering netbios calls or not.

=cut

sub nbtstat {
    tryuse('Net::NBName', die => 1);
    my $host = shift;
    my $ip = getip($host);
    my $nb = Net::NBName->new;
    
    print "nbtstat($host) :\n";

        unless (defined $ip) {
                print "[$host] No IP match.\n";
                return 0;
        }

    my $ns = $nb->node_status($ip);

    # Check for NetBIOS Info
    unless ($ns) {  
        print "[$host] No NetBIOS.\n";
        return 0;
    }

    my $server = 0;
    my $nbname = '';
    my $domain = '';
    my $nbuser = '';

    for my $rr ($ns->names) {
                my $suffix = defined $rr->suffix ? $rr->suffix : -1;
                my $G      = defined $rr->G ? $rr->G : '';
                my $name   = defined $rr->name ? $rr->name : '';

        if ($suffix == 0 and $G eq "GROUP") {
            $domain = $name;
        }
        if ($suffix == 3 and $G eq "UNIQUE") {
            $nbuser = $name;
        }
        if ($suffix == 0 and $G eq "UNIQUE") {
            $nbname = $name unless $name =~ /^IS~/;
        }
        if ($suffix == 32 and $G eq "UNIQUE") {
            $server = 1;
        }
    }
    my $mac = $ns->mac_address || '';
    $mac =~ s/-/:/g;

    unless ($nbname){
        print "[$host] No computer name found.\n";
        return 0;
    }
        
    if (!$mac or $mac eq '00:00:00:00:00:00'){
        # Just assume it's the last MAC we saw this IP at.
        $mac = sql_scalar('node_ip',['mac'],{'ip'=>$ip,'active'=>1});
        unless (defined $mac){
            print "[$host] No MAC in given or in DB.\n";
            return 0;
        }
        print "[$host] (No MAC)" if $DEBUG;
    }

    print "[$host] \\\\$domain\\$nbname $nbuser $mac ",$server ? 'server' : 'client', "\n";
    add_nbt($ip,$mac,$nbname,$domain,$server,$nbuser);

    return 1;
}
    
=item nbtwalk() 

Visits every node and trys to get its NetBIOS information.  

Calls nbtstat() for each device.  

=cut

sub nbtwalk {
    $start_time = time;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/netbios",1);
    
    # Get nodes
    my $days = $CONFIG{nbt_days} || 7;
    print "Grabbing NetBIOS from all nodes seen in last $days days. (". localtime() . ")...\n";

    # Preload Net::NBName so that we don't have to load it for
    # every node.
    tryuse('Net::NBName', die => 1);

    &load_old_nodes($days);
    print "  Searching ",scalar(keys(%$OldNodes))," nodes.\n" if $DEBUG;
    
    $controller = $$;
    foreach my $node (keys %$OldNodes){
        queue_process($node, 'nbtstat') if defined $OldNodes->{$node};
    }
    dispatcher('nbtstat', \&nbtstat);
    
    sql_vacuum('node_nbt','print'=>1); 

    &end;
}

=back

=head2 Maintenance Functions

=over

=item alias_clean() 

Routine to clean out devices that are now listed as aliases of another device. This is
usually necessary after a device has been merged into another one.

=cut

sub alias_clean {
    print "Cleaning out Aliases that showed up as devices :\n";
    
    my $aliases = sql_rows('device_ip',['ip','alias','dns'],{'ip' => \\'!= alias'});
    foreach my $row (@$aliases) {
        my $ip = $row->{ip};
        my $alias = $row->{alias};
        my $dns = $row->{dns};
        $dns = defined $dns ? $dns : '[No DNS]';
        my $exists = sql_scalar('device',['true'],{'ip'=>$alias});
        next unless (defined $exists and $exists);
        print "Deleting alias of $ip = $alias ($dns)\n";
        expire_device($alias,1)
    }

    print "Cleaning out Aliases of non-existant devices.\n";
    sql_do(qq/DELETE FROM device_ip WHERE ip NOT IN (SELECT ip FROM device)/);
}

=item arp_dump(dir) 

Dumps node_ip table to files arp_current and arp_archive.

=cut

sub arp_dump {
    my $dir = shift;

    print "Dumping node_ip table to $dir...\n";


    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;

    # Dump Current
    my $sth = sql_query('node_ip',['mac','ip as remote_ip','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                          {'active' => 1}, undef, 'order by remote_ip'
                        );

    &batch_mode("$dir/arp_current");
    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next unless $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{remote_ip};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-15s  %-17s  %-10d %-10d\n",
            $ip, $mac, $time_first, $time_last);
    }
    &batch_mode_end;

    # Dump Archive
    $sth = sql_query('node_ip',['mac','ip as remote_ip','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                          {'active' => 0}, undef, 'order by remote_ip'
                           );
    &batch_mode("$dir/arp_archive");
    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next if $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{remote_ip};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-15s  %-17s  %-10d %-10d\n",
            $ip, $mac, $time_first, $time_last);
    }
    &batch_mode_end;

    $BatchMode=$old_batch;

}

=item change_device_ip(from_ip, to_ip)

Used to move move over all the information from one device 
to a new IP address.  First tries to discover new device, then
proceeds to move over old information.  

=cut

sub change_device_ip {
    my ($from_ip,$to_ip) = @_;
    
    print "change_device_ip($from_ip,$to_ip)\n";

    return unless (defined $from_ip and defined $to_ip);

    &load_old_devices ;

    print "  Checking for Old Device ($from_ip)\n";
    unless (defined $OldDevices->{$from_ip}){
        print "  !$from_ip not found as device.\n";
        return 0;
    }

    if (defined $Aliases->{$from_ip}) {
        print "  !$from_ip is an alias. Using $Aliases->{$from_ip}.\n";
        $from_ip = $Aliases->{$from_ip};
    }
    
    &topo_load_file();

    print "  Adding New Device ($to_ip)\n";

    discover($to_ip); 

    &load_old_devices ;

    unless (defined $OldDevices->{$to_ip}){
        print "  !Device $to_ip did not discover.  Not moving old entries to this one. Fix and run again.\n";
        return 0;
    } 
    
    print "  Removing Old Device its Aliases, and Ports\n";
    expire_device($from_ip);
    
    print "  Moving old Nodes to New Device.\n";
    sql_do(qq/UPDATE node set switch='$to_ip' where switch='$from_ip'/);

    # TODO - Check to see if the port numbers have stayed the same, otherwise 
    #        axe the old nodes.

    return 1;
}

=item db_clean() 

Removes all the entries in C<node> that are switch ports. 

Checks for nodes on non existant ports and prints a warning

Removes nodes that are on uplink ports.

=cut

sub db_clean {
    print "Database Cleanup : \n";

    # See what devices exist
    &load_old_devices ;

    print "  Deleting nodes that are actually device ports...\n";
    my $num = sql_do(q/DELETE FROM node WHERE mac IN (select mac from device_port union
                                 select mac from device)/);
    print "    $num MAC entries deleted\n";
    $num = sql_do(q/DELETE FROM node_ip WHERE mac IN (select mac from device_port union
                                 select mac from device)/);
    print "    $num ARP entries deleted\n";
    
    print "  Checking for Nodes that exist on nonexistent ports:\n";
    # This query returns only rows from node that refer to a port
    #  that's not in device_port.
    my $sth = sql_query('node LEFT JOIN device_port ON device_port.ip=node.switch AND device_port.port=node.port',
                        ['node.mac','node.switch','node.port'],
                        {'device_port.ip' => 'IS NULL'});
    while (my $row = $sth->fetchrow_hashref()) {
        my $mac  = $row->{mac};  
        my $ip   = $row->{switch};
        my $port = $row->{port};
        
        my $have_device = defined $OldDevices->{$ip} ? 1 : 0;

        # If the device doesn't exist Delete it.
        # If the device exists and has ports, but not this port, delete the node
        # If the deviec exists and doesn't have ports, do not delete it.  Probably a refresh() error.
        my $nuke = 0;
        if ($have_device){
            my $ports = sql_scalar('device_port',['count(*)'],{ip=>$ip});
            if (defined $ports and $ports){
                print "    $mac \@ $ip/$port. Port no longer exists. Removed.\n";
                $nuke++;
            } else {
                print "    $mac \@ $ip/$port. Device has no ports.  Run -e $ip if appropriate.\n";
            }
        } else  {
            print "    $mac \@ $ip/$port. Device no longer exists. Removed.\n";
            $nuke++;
        }

        if ($nuke) {
            #print "nuking $mac $ip $port\n" if $DEBUG;
            sql_do(qq/DELETE from node where mac = '$mac' and switch = '$ip' and port = '$port'/);
        }
    }

    print("  Removing nodes that are listed on uplink ports...\n");
    # This query returns only the possible uplink ports
    #  that have nodes on them.
    my $dev_ports = sql_rows('device_port, node',
                ['distinct ip','device_port.port','remote_ip'],
                {'remote_ip' => 'IS NOT NULL',
                 'device_port.ip'=>\'node.switch',
                 'device_port.port'=>\'node.port'});

    foreach my $dev_port (@$dev_ports){
        my $ip        = $dev_port->{ip};
        my $port      = $dev_port->{port};
        my $remote_ip = $dev_port->{remote_ip};
        $remote_ip    = defined $Aliases->{$remote_ip} ? $Aliases->{$remote_ip} : $remote_ip;
        my $layers    = $OldDevices->{$remote_ip};

        print "$ip / $port -> $remote_ip " .
                    (defined($layers) ? "with layers $layers - deleting nodes"
                                      : "(not deleting, not discovered)") . "\n" if $DEBUG;
        next unless defined $layers;
        my $deleted;
        $deleted = sql_do(qq/DELETE FROM node WHERE switch='$ip' and port='$port'/);
        print "    $deleted nodes deleted from $ip / $port\n";
    }
    print "Done.\n"; 

    &expire_ips;
    sql_vacuum('node','print'=>1);
}

=item dev_dump() 

Dumps out the device,device_ip, and topology info from device_port to file 'devices'.

=cut

sub dev_dump {
    my $dir = shift;

    print "Dumping device and device_port tables to $dir...\n";

    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;
    
    &load_old_devices;
    
    &batch_mode("$dir/devices");

    # Make alias map
    my %alias_map;
    foreach my $alias (keys %$Aliases){
        my $dev = $Aliases->{$alias};

        push @{$alias_map{$dev}},$alias;
    }

    foreach my $dev (sort {sort_ip} keys %$OldDevices){
        print "$dev\n";
        if (defined $alias_map{$dev}){
            foreach my $alias (sort {sort_ip} @{$alias_map{$dev}}){
                print "\talias:$alias\n";
            }
        }

        # topology
        my $neighbors = sql_rows('device_port',['remote_ip','remote_port','port'],
                                {'remote_ip'=>'is not null','ip'=>$dev});

        foreach my $neighbor (sort {sort_ip} @$neighbors){

            my $port = $neighbor->{port};
            my $remote_ip = $neighbor->{remote_ip};
            my $remote_port = $neighbor->{remote_port};
            print "\tlink:$port,$remote_ip,$remote_port\n";
        }
    }

    &batch_mode_end;

    $BatchMode=$old_batch;
}

=item expire_data(type,days,archive_only)

C<type> can be : node,device,process

C<days> is a positive integer number of days in which an entry
has not been updated.

C<archive_only> for node only.

Removes devices and nodes that haven't been updated in C<days> days or
processes created C<days> days ago.  Process table clean up is for crashed or
improperly terminated jobs still in the table.  Called from nightly() and
controlled through the C<expire_*> directives in the config file.

Cheers to Brian Wilson for his patch for the start of this feature.

=cut

sub expire_data {
    my ($type, $days, $archive_only) = @_;
    $archive_only ||=0;

    unless (defined $type and $type =~ /^(node|device|process)$/i){
        print "expire_data : Data type (1st argument) must be either node, device, or process.\n";
        return;
    }
    
    unless (defined $days and $days =~ /^\d+$/ and $days > 0){
        print "expire_data : Age of data must be a positive number of days (2nd argument).\n";
        return;
    }
    
    print "expire_data($type,$days days,archive_only:$archive_only)\n";

    if ($type eq 'device'){
        my $devices = sql_rows('device',['ip','dns','age(last_discover) as age'],
                               {'age(last_discover)' => \\ "> interval '$days days'"}
                              );
        foreach my $dev (sort {sort_ip} @$devices){
            my $name = $dev->{dns} || $dev->{ip};
            printf("Removing %-15s %25s   Last Seen: %s\n",$dev->{ip},$name,$dev->{age});

            # TODO - Ping device first.  Some devices stop responding to SNMP but still exist.
            #        then issue warning and don't delete?

            expire_device($dev->{ip},1);
        }   
    }

    if ($type eq 'node'){
        my $sql = qq/DELETE FROM node WHERE AGE(time_last) > INTERVAL '$days days'/;
        $sql .= " AND NOT active" if $archive_only;

        my $rows = '';
        $rows = sql_do($sql);

        # note:expire_ips() should be run after this, and is in nightly() through db_clean()
        print "Deleted $rows rows from node.\n";

        $sql = qq/DELETE from node_ip where age(time_last) > interval '$days days'/;
        $sql .= " AND NOT active" if $archive_only;
        
        $rows = sql_do($sql);
        print "Deleted $rows rows from node_ip.\n";

        $sql = qq/DELETE from node_nbt where age(time_last) > interval '$days days'/;
        $sql .= " AND NOT active" if $archive_only;
        
        $rows = sql_do($sql);
        print "Deleted $rows rows from node_nbt.\n";
    }

    if ($type eq 'process'){
        my $sql = qq/DELETE FROM process WHERE AGE(creation) > INTERVAL '$days days'/;
        
        my $rows = '';
        $rows = sql_do($sql);
        print "Deleted $rows rows from process table.\n";
    }
}

=item expire_device(device,expire_nodes?)

Removes device from the database

Set second argument to true to remove all the connected nodes and their 
IP mappings as well.

=cut

sub expire_device {
    my ($devname,$expire_nodes) = @_;
    my $ip  = getip($devname);

    print "Expire Device $devname ($ip)\n";

    unless (length $ip) {
        print "  Device $devname doesn't resolve.\n";
        return;
    }

    my $dev = sql_hash('device',['*'],{'ip'=>$ip} );

    unless (defined $dev){
        print "  Device $devname ($ip) not found in database!\n";
        return;
    }

    my $dns = $dev->{dns} || '';
    print "  Removing $dns ($ip)...\n";
    # Get rid of device info
    sql_do(qq/DELETE from device where ip = '$ip'/);
    # Get rid of aliases
    print "  Removing Aliases of $dns ($ip)...\n";
    sql_do(qq/DELETE from device_ip where ip = '$ip'/);
    # Remove Ports
    print "  Removing Ports of $dns ($ip)...\n";
    sql_do(qq/DELETE from device_port where ip = '$ip'/);
    sql_do(qq/DELETE from device_port_power where ip = '$ip'/);
    sql_do(qq/DELETE from device_port_ssid where ip = '$ip'/);
    sql_do(qq/DELETE from device_port_vlan where ip = '$ip'/);
    sql_do(qq/DELETE from device_port_wireless where ip = '$ip'/);
    # Remove Modules
    print "  Removing Modules of $dns ($ip)...\n";
    sql_do(qq/DELETE from device_module where ip = '$ip'/);

    if (defined $expire_nodes and $expire_nodes){
      &expire_nodes($ip);  
    }

}

=item expire_nodes(device,archive_only,port)

Removes entries from node and node_ip for a given device.

Set port to limit the expiration to a specific port.

Set archive_only to 1 to archive the nodes on the device.

=cut

sub expire_nodes {
    my ($dev,$archive,$port) = @_;
    my $ip  = getip($dev);

    print "Expire Nodes($dev)\n";
    unless (length $ip) {
        print "  Device $dev doesn't resolve.\n";
        return;
    }

    my %where_hash = ('switch' => $ip);
    my $where = "switch='$ip'";
    $where .= " AND port='$port'" if defined $port; 
    $where_hash{port} = $port if defined $port;
    
    # grab mac count
    my $macs = sql_rows('node',['count(mac)'],\%where_hash,undef,"GROUP BY mac");
     
    my $count = $macs->[0]->{count} || 0;
    if (defined $archive and $archive){
        # De-activate nodes
        print "  Archiving $count entries for $where\n";
        sql_do(qq/UPDATE node SET active=false WHERE $where/);
    } else {
        # Delete nodes
        print "  Deleting $count entries for $where\n";
        sql_do(qq/DELETE FROM node WHERE $where/);
    }
}

=item expire_nodes_subnet(subnet)

Subnet is in CIDR format, or any other format that Postgres likes.

    192.168.0.0/24

Runs expire_ips afterwards to cleanup.

=cut

sub expire_nodes_subnet {
    my $subnet  = shift;
    my $confirm = shift;
    
    print "expire_nodes_subnet($subnet)\n";
    my $dbsubnet = dbh_quote($subnet);

    my $devices = sql_rows('device',['ip','dns','location'],{'ip' => \\"<< $dbsubnet"});

    unless (defined $devices and scalar @$devices){
        print "No devices found in subnet $subnet.\n";
        print "Are you sure you specified the subnet CIDR format? Eg. 192.168.0.0/24\n";
        return;
    }

    print "Found Matching Devices : \n";
    foreach my $dev (sort { ($a->{dns}||$a->{ip}) cmp ($b->{dns}||$b->{ip}) } @$devices){
        my $name = $dev->{dns} || $dev->{ip};
        $name =~ s/\Q$CONFIG{domain}\E//;
        my $ip   = $dev->{ip};
        my $location = $dev->{location} || '';
        printf "  %-15s %-15s %s\n",$ip, substr($name,0,15), substr($location,0,46);
    }

    my $dev_count = scalar(@$devices);

    unless (defined $confirm){
        print "Enter 'delete' to confirm Exipration of nodes on these $dev_count devices.\n";
        print "Confirm : ";
        $confirm = <STDIN>;
        chomp $confirm;               
    } 
    
    unless ($confirm eq 'delete'){
        print "Never Mind.\n";
        return;
    }

    foreach my $dev (@$devices){
        my $ip = $dev->{ip};
        expire_nodes($ip);
    }

    &expire_ips;

}

=item expire_ips()

Expires MAC->IP mappings for MAC addresses not present in node table.

=cut

sub expire_ips {
    print "expire_ips()\n";

    my $rows = sql_do("DELETE FROM node_ip WHERE mac IN (SELECT DISTINCT mac FROM node_ip LEFT JOIN node USING (mac) WHERE port IS NULL)");
    $rows = $rows || 0;
    print "Deleted $rows rows.\n";
    sql_vacuum('node_ip','print'=>1);
}

=item mac_dump() 

Dumps the node table out to mac_current.txt and mac_archive.txt.
Adds a day stamp, no time-stamp.

=cut

sub mac_dump {
    my $dir=shift;

    print "Dumping node table to $dir...\n";

    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;

    # Dump Current
    my $sth = sql_query('node',['mac','switch','port','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 1}, undef, 'order by mac'
                        );

    &batch_mode("$dir/mac_current");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next unless $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{switch};
        my $port = $row->{port};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-15s  %-25s %-10d %-10d\n",
            $mac, $ip, $port, $time_first, $time_last);
    }
    &batch_mode_end;

    # Dump Archive
    $sth = sql_query('node',['mac','switch','port','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 0}, undef, 'order by mac'
                           );

    &batch_mode("$dir/mac_archive");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next if $active;
        my $mac = $row->{mac};  
        my $ip  = $row->{switch};
        my $port = $row->{port};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-15s  %-25s %-10d %-10d\n",
            $mac, $ip, $port, $time_first, $time_last);
    }

    &batch_mode_end;

    $BatchMode=$old_batch;
}

=item netbios_dump() 

Dumps the node_nbt table out to netbios_current.txt and netbios_archive.txt.
Adds a day stamp, no time-stamp.

=cut

sub netbios_dump {
    my $dir=shift;

    print "Dumping node_nbt table to $dir...\n";

    # Force to batch mode to not output to screen.
    my $old_batch = $BatchMode;
    $BatchMode=1;

    # Dump Current
    my $sth = sql_query('node_nbt',['mac','nbname','domain','server','nbuser','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 1}, undef, 'order by mac'
                        );

    &batch_mode("$dir/netbios_current");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next unless $active;
        my $mac    = $row->{mac};  
        my $name   = $row->{nbname};
        my $domain = $row->{domain};
        my $server = $row->{server};
        my $user   = $row->{nbuser};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-16s  %-16s %-1d %-16s %-10d %-10d\n",
            $mac, $name, $domain, $server, $user, $time_first, $time_last);
    }
    &batch_mode_end;

    # Dump Archive
    $sth = sql_query('node_nbt',['mac','nbname','domain','server','nbuser','active',
                                    'extract(epoch from time_first) as time_first', 
                                    'extract(epoch from time_last) as time_last'],
                           {'active' => 0}, undef, 'order by mac'
                           );

    &batch_mode("$dir/netbios_archive");

    while (my $row = $sth->fetchrow_hashref()) {
        my $active = $row->{active};
        next if $active;
        my $mac    = $row->{mac};  
        my $name   = $row->{nbname};
        my $domain = $row->{domain};
        my $server = $row->{server};
        my $user   = $row->{nbuser};
        my $time_first = $row->{time_first};
        my $time_last = $row->{time_last};
        printf("%-17s  %-16s  %-16s %-1d %-16s %-10d %-10d\n",
            $mac, $name, $domain, $server, $user, $time_first, $time_last);
    }

    &batch_mode_end;

    $BatchMode=$old_batch;
}

=item nightly(no_batch)

Nightly maintance routine that creates backups of the device,node, and node_ip tables. 

Calls expire_data(), nmis_dump(),
mac_dump(), arp_dump(), dev_dump(), netbios_dump(),
db_clean() and VACUUM ANALYZE

=cut

sub nightly {
    my $no_batch = shift || 0;
    # Log backup
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/nightly",1) unless (defined $no_batch and $no_batch);
    print "nightly() - Starting nightly cleanup and backup routines\n";

    print "  Cleaning and clearing data...\n";

    # Expire Devices that are X days old
    if (defined $CONFIG{expire_devices} and $CONFIG{expire_devices} =~ /^\d+$/
        and $CONFIG{expire_devices} > 0) 
    {
        print "  expire_devices: Deleting Devices that are older than $CONFIG{expire_devices} days old.\n\n";
        expire_data('device',$CONFIG{expire_devices});
    }
    
    # Expire Archived Node Data X days old
    if (defined $CONFIG{expire_nodes_archive} and $CONFIG{expire_nodes_archive} =~ /^\d+$/
        and $CONFIG{expire_nodes_archive} > 0) 
    {
        print "  expire_nodes_archive: Deleting Archived Node data older than $CONFIG{expire_nodes_archive} days old.\n\n";
        expire_data('node',$CONFIG{expire_nodes_archive},1);
    }

    # Expire Nodes that are X days old
    if (defined $CONFIG{expire_nodes} and $CONFIG{expire_nodes} =~ /^\d+$/
        and $CONFIG{expire_nodes} > 0) 
    {
        print "  expire_nodes: Deleting Nodes older than $CONFIG{expire_nodes} days old.\n\n";
        expire_data('node',$CONFIG{expire_nodes});
    }

    # Remove processes which are stale from crashed or improperly terminated
    # jobs which were created X days ago
    if (defined $CONFIG{expire_processes} and $CONFIG{expire_processes} =~ /^\d+$/
        and $CONFIG{expire_processes} > 0) 
    {
        print "  expire_processes: Deleting processes created over $CONFIG{expire_processes} day(s) ago.\n\n";
        expire_data('process',$CONFIG{expire_processes});
    }

    # This will clean all node entries on unused ports and uplinks etc. Also runs expire_ips()
    &db_clean;

    my $datadir = homepath('datadir', 'data');
    print "  Backing up Data to $datadir\n";

    die "Can't write to Data Directory '$datadir'. $!\n" unless -w $datadir;

    &nmis_dump;

    &mac_dump("mac/$month");

    &arp_dump("arp/$month");

    &dev_dump("dev/$month");

    &netbios_dump("netbios/$month");

    print "  Running Database Vacuum...\n";
    my $dbh = dbh();
    # Get all tables in public schema, do not place name of the schema before
    # the table name.  This should be all tables for which netdisco user has
    # permission
    my @tables = $dbh->tables( '', 'public', '%', 'TABLE', {pg_noprefix => 1} );
    foreach my $db ( @tables ) {
        sql_vacuum("$db",'print'=>1);
    }

    &batch_mode_end unless $no_batch;
}

=item nmis_dump()

Dumps the device table out to NMIS (http://www.sins.com.au/nmis/) style config file.

=cut

sub nmis_dump {
    
    my $dump_file = $CONFIG{nmis_dump};
    unless (defined $dump_file){
        $DEBUG and print "nmis_dump() Config option nmis_dump not set.\n";
        return;
    }

    print "nmis_dump() - Dumping to $dump_file.csv \n";

    # Force to batch mode to not output to screen.
    local $CONFIG{logextension} = 'csv';
    my $old_batch = $BatchMode;
    $BatchMode=1;
    &batch_mode($dump_file,0,1);    # no header, no timestamp
print << "end_print";
#
# Netdisco - NMIS config file dump
#
# Header
#
node    community       snmpport        net     devicetype      role    group   collect active
#
# Data
#
end_print
    my $devices = sql_rows('device',['ip','dns','snmp_comm','layers']);

    foreach my $dev (sort { ($a->{dns}||$a->{ip}) cmp ($b->{dns}||$b->{ip}) } @$devices){
        my $ip = $dev->{ip};
        my $layers = $dev->{layers};
        my $device_type = 'switch';
           $device_type = 'router' if has_layer($layers,3);
        my $node        = $dev->{dns}           || $ip;
        my $community   = $dev->{snmp_comm}     || 'public';
        my $snmpport    = $CONFIG{nmis_port}    || 161;
        my $net         = $CONFIG{nmis_net}     || 'lan';
        my $role        = $CONFIG{nmis_role}    || 'core';
        my $group       = $CONFIG{nmis_group}   || 'Network';
        my $collect     = $CONFIG{nmis_collect} || 'true'; 
        my $active      = $CONFIG{nmis_active}  || 'true';
        print join("\t",($node,$community,$snmpport,$net,$device_type,$role,$group,$collect,$active)),"\n";
    }
    batch_mode_end(1);      # dont compress
    $BatchMode=$old_batch;

}

=back

=head2 Graphing Functions

=over

=item graph(no_batch) 

Creates netmap of network.  Calls Netdisco::make_graph() and graph_each()

=cut

sub graph {
    my $no_batch = shift || 0;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/graph") unless $no_batch;
    print "graph() - Creating Graphs.\n";

    tryuse('GraphViz', ver => '2.02', die => 1);

    my $G = make_graph();

    unless (defined $G){
        print "graph() - make_graph() failed.  Try running with debug (-D)\n";
        return;
    }

    my @S = $G->connected_components;

    # Count number of nodes in each subgraph
    my %S_count;
    for (my $i=0;$i< scalar @S;$i++){
        $S_count{$i} = scalar @{$S[$i]};
    }
    
    foreach my $subgraph (sort { $S_count{$b} <=> $S_count{$a} } keys %S_count){
        my $SUBG = $G->copy;
        print "\$S[$subgraph] has $S_count{$subgraph} nodes.\n";
        
        # Remove other subgraphs from this one
        my %S_notme = %S_count;
        delete $S_notme{$subgraph};
        foreach my $other (keys %S_notme){ 
            print "Removing Non-connected nodes: ",join(',',@{$S[$other]}),"\n";
            $SUBG->delete_vertices(@{$S[$other]})
        }
        
        # Create the subgraph
        my $timeout = defined $CONFIG{graph_timeout} ? $CONFIG{graph_timeout} : 60;

        eval {
            alarm($timeout*60);
            graph_each($SUBG,'');
            alarm(0);
        };
        if ($@) {
            if ($@ =~ /timeout/){
                print "! Creating Graph timed out!\n";
            } else {
                print "\n$@\n";
            }
        }
        
        # Facility to create subgraph for each non-connected network segment.  
        # Right now, let's just make the biggest one only.
        last;
    }

    &batch_mode_end unless $no_batch;
}

=item graph_each(Graph_obj, name) 

Generates subgraph. Called from graph().  Calls graph_node().  

Does actual GraphViz calls.

=cut

sub graph_each  {
    my ($G,$name) = @_;

    print "Creating new Graph\n";

    my $graph_defs = {
                     'bgcolor' => $CONFIG{graph_bg}        || 'black',
                     'color'   => $CONFIG{graph_color}     || 'white',
                     'overlap' => $CONFIG{graph_overlap}   || 'scale',
                     'fontpath'=> homepath('graph_fontpath',''),
                     'ranksep' => $CONFIG{graph_ranksep}   || 0.3,
                     'nodesep' => $CONFIG{graph_nodesep}   || 2,
                     'ratio'   => $CONFIG{graph_ratio}     || 'compress',
                     'splines' => ($CONFIG{graph_splines} ? 'true' : 'false'),
                     'fontcolor' => $CONFIG{node_fontcolor} || 'white',
                     'fontname'  => $CONFIG{node_font}      || 'lucon',
                     'fontsize'  => $CONFIG{node_fontsize}  || 12,
                     };
    my $node_defs = { 
                    'shape'     => $CONFIG{node_shape}     || 'box',
                    'fillcolor' => $CONFIG{node_fillcolor} || 'dimgrey',
                    'fontcolor' => $CONFIG{node_fontcolor} || 'white',
                    'style'     => $CONFIG{node_style}     || 'filled',
                    'fontname'  => $CONFIG{node_font}      || 'lucon',
                    'fontsize'  => $CONFIG{node_fontsize}  || 12,
                    'fixedsize' => ($CONFIG{node_fixedsize} ? 'true' : 'false'),
                    };
    $node_defs->{height} = $CONFIG{node_height} if defined $CONFIG{node_height};
    $node_defs->{width}  = $CONFIG{node_width}  if defined $CONFIG{node_width};
    my $edge_defs = {
                    'color' => $CONFIG{edge_color}         || 'wheat',
                    };

    my $epsilon = undef;
    if (defined $CONFIG{graph_epsilon}){
        $epsilon = "0." . '0' x $CONFIG{graph_epsilon} . '1';
    }
    
    my %gv = (
               directed => 0,
               layout   => $CONFIG{graph_layout} || 'twopi',
               graph    => $graph_defs,
               node     => $node_defs,
               edge     => $edge_defs,
               width    => $CONFIG{graph_x}      || 30,
               height   => $CONFIG{graph_y}      || 30,
               epsilon  => $epsilon,
              );

    my $gv = new GraphViz(%gv);
    my $gen_json=undef;
    
    if (defined $CONFIG{graph_json} and $CONFIG{graph_json}){
        my $graph_json = homepath('graph_json');
        print "  Creating json graph: $graph_json\n";
        open (JSONFILE, '>'.$graph_json);
        print JSONFILE "{\n";
        print JSONFILE "  \"nodes\": [\n";
        $gen_json=1;
    }
    
    my %node_map = ();
    my @nodes = $G->vertices;
    my @my_nodes=();
    foreach my $dev (@nodes){
        my $node_name = graph_addnode($gv,$dev);
        $node_map{$dev} = $node_name;
        #print "$dev->$node_name ".$gv->_quote_URL($node_name)."\n";
        my %this_node=jsongraph_addnode($dev);
        my $str="    {\n".
                "      \"name\": \"$this_node{label}\",\n".
                "      \"id\": \"$this_node{id}\",\n".
                "      \"color\": \"$this_node{fillcolor}\",\n".
                "      \"type\": \"$this_node{type}\",\n".
                "      \"url\": \"$this_node{URL}\"\n".
                "    }";
        push(@my_nodes,$str)
    }
    print JSONFILE join(',',@my_nodes) if $gen_json;
    print JSONFILE "  ],\n" if $gen_json;

    my $root_ip = defined $CONFIG{root_device} ? getip($CONFIG{root_device}) : undef;
    if (defined $root_ip and defined $node_map{$root_ip}){
        my $gv_root_name = $gv->_quote_name($root_ip);
        if (defined $gv_root_name){
            $gv->{GRAPH_ATTRS}->{root}=$gv_root_name;
        }
    }

    my @edges = $G->edges;

    print JSONFILE "  \"links\": [\n" if $gen_json;
    my @my_links=();
    while (my $e = shift @edges){
        my $link = $e->[0];
        my $dest = $e->[1];
        #print $link;
        my $speed = $netdisco::GRAPH_SPEED{$link}->{$dest}->{speed};
        if (!defined($speed)) {
            print "  ! No link speed for $link -> $dest\n";
            $speed = 0;
        }
        my %edge = ();
        my $val = ''; my $suffix = '';
        if ($speed =~ /^([\d.]+)\s+([a-z])bps$/i) {
            $val = $1; $suffix = $2;
        }
        if ( ($suffix eq 'k') or ($speed =~ m/(t1|ds3)/i) ){
            $edge{color} = 'green';
            $edge{style} = 'dotted';
        }
        if ($suffix eq 'M'){
            if ($val < 10.0){
                $edge{color} = 'green';
                #$edge{style} = 'dotted';
                $edge{style} = 'dashed';
            } elsif ($val < 100.0){
                $edge{color} = '#8b7e66'; 
                #$edge{style} = 'normal';
                $edge{style} = 'solid';
            } else {
                $edge{color} = '#ffe7ba';
                $edge{style} = 'solid';
            }
        }
        if ($suffix eq 'G'){
            #$edge{style} = 'bold';
            $edge{color} = 'cyan1';
        }

        # Add extra styles to edges (mainly for modifying width)
        if(defined $CONFIG{edge_style}) {
            $edge{style} .= "," . $CONFIG{edge_style};
        }

        my $str="    {\n".
                "      \"source\": \"$link\",\n".
                "      \"target\": \"$dest\"\n".
                "    }";
        push(@my_links,$str);

        $gv->add_edge($link => $dest, %edge );
    }
    print JSONFILE join(',',@my_links) if $gen_json;
    print JSONFILE "  ]}\n" if $gen_json;
    
    print "Ignore all warnings about node size.\n";

    if (defined $CONFIG{graph_raw} and $CONFIG{graph_raw}){
        my $graph_raw = homepath('graph_raw');
        print "  Creating raw graph: $graph_raw\n";
        $gv->as_canon($graph_raw);
    }
    if (defined $CONFIG{graph} and $CONFIG{graph}){
        my $graph_gif = homepath('graph');
        print "  Creating graph: $graph_gif \n";
        $gv->as_gif($graph_gif);
    }
    if (defined $CONFIG{graph_png} and $CONFIG{graph_png}){
        my $graph_png = homepath('graph_png');
        print "  Creating png graph: $graph_png\n";
        $gv->as_png($graph_png);
    }
    if (defined $CONFIG{graph_map} and $CONFIG{graph_map}){
        my $graph_map = homepath('graph_map');
        print "  Creating CMAP : $graph_map\n";
        $gv->as_cmap($graph_map);
    }

    if (defined $CONFIG{graph_svg} and $CONFIG{graph_svg}){
        my $graph_svg = homepath('graph_svg');
        print "  Creating SVG : $graph_svg\n";
        $gv->as_svg($graph_svg);
    }

}

=item graph_addnode(graphviz_obj,node_ip) 

Checks for mapping settings in config file and adds node to the GraphViz object.

=cut

sub graph_addnode {
    my $gv = shift;
    # non lexical on purpose
    use vars qw/$ip $label $isdev $devloc $devlayer $model/;
    $ip    = shift;
    $label = $netdisco::GRAPH{$ip}->{dns};
    $isdev = $netdisco::GRAPH{$ip}->{isdev};
    $devloc = $netdisco::GRAPH{$ip}->{location};
    $devlayer = $netdisco::GRAPH{$ip}->{layer};
    $model = $netdisco::GRAPH{$ip}->{model};

    my %node = ();

    $label = "($ip)" unless defined($label);
    my $domain = $CONFIG{domain};
    $label =~ s/\Q$domain\E//;
    # hack
    $label =~  s/\.resnet//;

    $node{label} = $label;

    # Dereferencing the scalar by name below
    #   requires that the variable be non-lexical (not my)
    #   we'll create some local non-lexical versions 
    #   that will expire at the end of this block
    # Node Mappings
    foreach my $map (@{$CONFIG{node_map}}){
        my ($var,$regex,$attr,$val) = split(':',$map);

        { no strict 'refs';
           $var =  ${"$var"}; 
        }

        next unless defined $var;

        if ($var =~ /$regex/) {
            print "Giving node $ip $attr = $val\n" if $DEBUG;
            $node{$attr} = $val;
        }
    }

    # URL for image maps
    if ($isdev) {
        $node{URL} = "device.html?ip=$ip";
    } else {
        $node{URL} = "node.html?node=$ip";
        # Overrides any colors given to nodes above. Bug 1094208
        $node{fillcolor} = $CONFIG{node_problem} || 'red';
    }

    if ($CONFIG{graph_clusters} && $devloc) {
        # This odd construct works around a bug in GraphViz.pm's
        # quoting of cluster names.  If it has a name with spaces,
        # it'll just quote it, resulting in creating a subgraph name
        # of cluster_"location with spaces".  This is an illegal name
        # according to the dot grammar, so if the name matches the
        # problematic regexp we make GraphViz.pm generate an internal
        # name by using a leading space in the name.
        #
        # This is bug ID 16912 at rt.cpan.org -
        # http://rt.cpan.org/NoAuth/Bug.html?id=16912
        #
        # Another bug, ID 11514, prevents us from using a combination
        # of name and label attributes to hide the extra space from
        # the user.  However, since it's just a space, hopefully it
        # won't be too noticable.
        my($loc) = $devloc;
        $loc = " " . $loc if ($loc =~ /^[a-zA-Z](\w| )*$/);
        $node{cluster} = { name => $loc };
    }

    my $rv = $gv->add_node($ip, %node);
    return $rv;
}

=item jsongraph_addnode(node_ip) 

Checks for mapping settings in config file and adds node to the JSON object.

=cut

sub jsongraph_addnode {
    # non lexical on purpose
    use vars qw/$ip $label $isdev $devloc $devlayer $model/;
    $ip    = shift;
    $label = $netdisco::GRAPH{$ip}->{dns};
    $isdev = $netdisco::GRAPH{$ip}->{isdev};
    $devloc = $netdisco::GRAPH{$ip}->{location};
    $devlayer = $netdisco::GRAPH{$ip}->{layer};
    $model = $netdisco::GRAPH{$ip}->{model};

    my %node = ();

    $label = "($ip)" unless defined($label);
    my $domain = $CONFIG{domain};
    $label =~ s/\Q$domain\E//;
    # hack
    $label =~  s/\.resnet//;

    $node{id} = $ip;
    $node{label} = $label;

    # Dereferencing the scalar by name below
    #   requires that the variable be non-lexical (not my)
    #   we'll create some local non-lexical versions 
    #   that will expire at the end of this block
    # Node Mappings
    foreach my $map (@{$CONFIG{node_map}}){
        my ($var,$regex,$attr,$val) = split(':',$map);

        { no strict 'refs';
           $var =  ${"$var"}; 
        }

        next unless defined $var;

        if ($var =~ /$regex/) {
            print "Giving node $ip $attr = $val\n" if $DEBUG;
            $node{$attr} = $val;
        }
    }

    # URL for image maps
    if ($isdev) {
        $node{URL} = "device.html?ip=$ip";
        $node{type} = "device";
    } else {
        $node{URL} = "node.html?node=$ip";
        $node{type} = "node";
        # Overrides any colors given to nodes above. Bug 1094208
        $node{fillcolor} = $CONFIG{node_problem} || 'grey';
    }

    if ($CONFIG{graph_clusters} && $devloc) {
        my($loc) = $devloc;
        $loc = " " . $loc if ($loc =~ /^[a-zA-Z](\w| )*$/);
        $node{cluster} = { name => $loc };
    }

    return %node;
}

=back

=head2 Admin Daemon

=over

=item admin_daemon_ctl(cmd)

start,stop,restart,status

=cut

sub admin_daemon_ctl {
    my $cmd = shift;

    # TODO : This months thing needs to get pushed into batch_mode()
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    # Allow nightly restart to not barf emails
    &batch_mode("logs/$month/daemon_ctl",1);

    if ($cmd eq 'restart') {
        &admin_daemon_ctl('stop');
        &admin_daemon_ctl('start');
    }

    if ($cmd eq 'start'){
        &admin_daemon; 
    }

    if ($cmd eq 'status'){
        my $status = &admin_daemon_status;
        if ($status) {
            print "Admin Daemon is running under pid $status.\n";
        } else {
            print "Admin Daemon is not currently running.\n";
        }
    }

    if ($cmd eq 'stop'){
        my $pid = &admin_daemon_status;
        if ($pid) {
            print "Stopping admin daemon ($pid).\n\n Waiting until current job completes ";
            kill INT => $pid;
            while(admin_daemon_status($pid)){
                print ".";
                sleep(1);
            }
            print "\n";
        } else {
            print "Admin daemon is not currently running!\n";
        }
    }
    &end;
}

=item admin_daemon_status(pid)

Returns 0 if daemon is not running or returns pid number if running.

pid argument is optional, used in stop function

=cut

sub admin_daemon_status {
    my $pid = shift || &admin_daemon_pid;

    if (defined $pid){
        if (kill 0 => $pid) {
            print "Admin Daemon is already running. ($pid)\n" if $DEBUG;
            return $pid;
        } elsif ($! == EPERM) {             # changed uid
            warn "Admin Daemon ($pid) is running under another user, out of our control.\n";
            return $pid;
        } elsif ($! == ESRCH) {
            print "Admin Daemon ($pid) is deceased, starting new one.\n" if $DEBUG;  # or zombied
            return 0;
        } else {
            warn "No status of $pid: $!\n";
            return 0;
        }
    }
    return 0;
}

=item admin_daemon() 

Resident copy of netdisco to handle requests from the admin panel.

=cut

sub admin_daemon {
    my $pid = undef;
    # Check if we're already running
    if ($pid = &admin_daemon_status){
        print "Admin Daemon is already running. ($pid)\n";
        return;
    }

    $DaemonMode = 1;
    $BatchMode = 1;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);

    my $end_flag = 0;

    local %SIG;
    $SIG{INT} = $SIG{USR1} = $SIG{TERM} = 
        sub {$end_flag++;};
    $SIG{PIPE} = 'IGNORE';

    print "Starting new admin panel daemon\n";
    &batch_mode("logs/$month/daemon",1);
    set_status("admin daemon");

    #
    # Daemonize
    #
    # http://www.unixguide.net/unix/programming/1.7.shtml
    # perl_networking/source/ch14/Daemon.pm
    if (defined $CONFIG{daemon_bg} and $CONFIG{daemon_bg} ){
        die "Can't fork (1): $!\n" unless defined($pid = fork());
        exit if $pid; # Exit parent thread

        POSIX::setsid();     # become session leader

        # Fork again so new parent / session group leader can exit
        die "Can't fork (2): $!\n" unless defined($pid = fork());
        exit if $pid; # Exit parent thread

        chdir($CONFIG{'home'});
        umask(0);
        #STDOUT is taken care of in &batch_mode
        open(STDIN, "</dev/null");
        open(STDERR,">/dev/null");
    }

    $pid = $$;

    # Write out pid file
    &admin_daemon_pid($pid);

    print "PID:$pid\n";

    my $poll_interval = $CONFIG{daemon_poll} || 2;

    # Create log dir
    my $datadir = $CONFIG{datadir};

    # Mark left over jobs as bad
    sql_do("UPDATE admin SET status='error' WHERE status = 'running';"); 
    # hmm, looks like insert_or_update() doesnt work for this sort of thing, assumes insert cuz no cases exist.

    # Event Loop
    until ($end_flag){
        # TODO - Die if the database isn't there. 

        my $jobs = sql_rows('admin',['job','extract(epoch from entered) as entered',
                                     'device','action','status', 'username','debug','subaction',
                                     'port','userip','log'],
                            {'status' => 'queued'} );

        # Run each Job
        foreach my $job (sort {$a->{entered} <=> $b->{entered}} @$jobs) {
            updateconfig();
            admin_daemon_job($job);
            last if $end_flag;
        }

        sleep($poll_interval) unless $end_flag;
    }

    print "Daemon ending ($pid).\n";
}

=item admin_daemon_pid(pid_to_write)

If not supplied arguments, Reads pid of daemon pid from F<netdisco_daemon.pid>

If supplied arguments, writes the pid out to that file.

=cut

sub admin_daemon_pid {
    my $pid = shift;
    my $pid_file = homepath('daemon_pid', 'netdisco_daemon.pid');

    if (defined $pid) {
        print "Writing pid:$pid to $pid_file\n" if $DEBUG;
        open (PIDFILE,"> $pid_file") or die "Can't open $pid_file. $!\n";
        print PIDFILE $pid;
        close (PIDFILE) or die "Can't write $pid_file. $!\n";
    } else {
        print "Reading pid from $pid_file\n" if $DEBUG;
        open (PIDFILE,"< $pid_file") or return undef;
        my $pid = (<PIDFILE>);
        chomp($pid);
        close (PIDFILE);
        return $pid;
    }
}

=item admin_daemon_job(job_obj)

Runs each job. Redirects output to data/admin/job-num-date.log
job_obj is the sql hash object for each job.

=cut

sub admin_daemon_job {
    my $job = shift;
    my $id     = $job->{job};
    my $cmd    = $job->{action};
    my $dev    = $job->{device};
    my $debug  = $job->{debug};
    my $subaction = $job->{subaction};

    printf("Daemon: %s Start Job %s: %s %s %s\n",
        scalar(localtime),$id,$cmd, defined $dev ? $dev : '', defined $subaction ? $subaction : '');

    # init Variables
    %Discovered = ();
    %Discovered_Alias = ();
    @Discover_Queue = ();
    %NoCDP = ();
    %UnDiscovered = ();

    # Set to running
    sql_begin();
    insert_or_update('admin',{'job'=>$id },{'status'=>'running', 'started' => scalar(localtime)});
    sql_commit();

    # Capture output
    &batch_mode("admin/job-$id");
    my $old_debug = $DEBUG;
    $DEBUG = $debug;

    # Make sure we don't get our output yanked out from under us
    $BatchMode = 0;

    # Device tasks
    my $job_error = 0;
    if ($cmd eq 'macsuck') {
        &load_old_devices;
        &mac_getportmacs;
        &macsuck($dev);
    }

    elsif ($cmd eq 'arpnip') {
        &mac_getportmacs;
        &arpnip($dev);
    }

    elsif ($cmd eq 'refresh') {
        &topo_load_file;
        &discover($dev);
    }

    elsif ($cmd =~ /^delete(\+nodes)?$/) {
        my $del_nodes = $1 eq '+nodes' ? 1 : 0;
        &expire_device($dev,$del_nodes); 
    }

    elsif ($cmd =~ /^nodes-(del|arc)$/){
        my $subcmd = $1;
        my $port = $subaction;
        &expire_nodes($dev, $subcmd eq 'arc' ? 1 : 0, $port);
    }

    elsif ($cmd eq 'portcontrol' or $cmd eq 'vlan'){
        $job_error = port_switch($job); 
    }

    elsif ($cmd eq 'location') {
        $job_error = location_set($job);
    }

    # Discover Tasks

    elsif ($cmd eq 'discover'){
        &discover($subaction);
    }
    
    elsif ($cmd eq 'discover_run'){
        &run($subaction); 
    }

    elsif ($cmd eq 'discover_new'){
        local $New_Only = 1; 
        &run($subaction);
    }

    # Global Tasks
    elsif ($cmd eq 'expire_ips'){
        &expire_ips;
    }

    elsif ($cmd eq 'arpwalk') {
        &arpwalk;
    }

    elsif ($cmd eq 'macwalk') {
        &macwalk;
    }

    elsif ($cmd eq 'nbtwalk') {
        &nbtwalk;
    }

    elsif ($cmd eq 'graph'){
        &graph(1);    
    }

    elsif ($cmd eq 'backup'){
        &nightly(1);
    }

    elsif ($cmd eq 'change_ip'){
        &change_device_ip($dev,$subaction);
    }

    elsif ($cmd eq 'clean_nodes'){
        &db_clean;
    }

    elsif ($cmd eq 'clean_alias'){
        &alias_clean;
    }
    
    else {
        print "Command $cmd not supported.\n";
        $job_error++;
    }

    # Clean Up
    $DEBUG = $old_debug;
    $BatchMode = 1;
    my $output_file = &batch_mode_end('no compress');
    open(OUTFILE, "<$output_file") or die "admin_daemon_job() Can't open $output_file. $!\n";

    # Slurp in log countents to a scalar.
    my $log = undef;
    {
        local $/ = undef;
        $log = <OUTFILE>;
    }
    close (OUTFILE);

    # Mark job done
    my $status = $job_error ? 'error' : 'done';
    sql_begin();
    insert_or_update('admin',{'job'=>$id },{'status'=>$status, 
                              'finished' => scalar(localtime), 'log'=>$log}
                    );
    sql_commit();

    print "Daemon: ".scalar(localtime) . " End Job $id\n";

    return undef;
}

=item save_dirty_configs(time)

Looks at the job list for the previous $time minutes in the past and attempts to save the
configuration on devices that finished a job in that time period.

Currently only supporting copy_run_start() for CiscoConfig-supporting devices.

=cut

sub save_dirty_configs {
    my $time = shift;
    my $oldest = time - $time * 60;
    my %devs;

    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    my $month = sprintf("%d%02d",$year+1900,$mon+1);
    &batch_mode("logs/$month/saveconfigs", 1);

    printf "Starting configuration saving at %s for devices changed since %s (%d minutes).\n", scalar(localtime), scalar(localtime($oldest)), $time;

    my $jobs = sql_rows('admin',['job', 'finished', 'device','action'],
                        {'status' => 'done', 'action' => [['portcontrol','vlan']],
                         'extract(epoch from finished)' => \\"> $oldest", } );

    printf "Collecting devices from jobs during specified interval...\n";

    foreach my $job (@$jobs) {
        if ($DEBUG) {
            printf "Found jobs:\n";
            foreach my $key (keys %$job) {
                printf "%s = %s, ", $key, $job->{$key} || "";
            }
            printf "\n";
        }

        printf "[%s] Adding to list.\n", $job->{"device"};
        $devs{$job->{"device"}} = 1;
    }

    printf "Saving configurations on collected devices...\n";

    foreach my $dev (keys %devs) {
        printf "[%s] Saving configuration...\n", $dev;
        my $rw = get_device_rw($dev);
        if(!defined $rw) {
            printf "[%s] Could not open as RW.\n", $dev;
            next;
        }
        if($rw->can("copy_run_start")) {
            if($rw->copy_run_start()) {
                printf "[%s] Saved configuration.\n", $dev;
            } else {
                printf "[%s] Configuration save failed.\n", $dev;
                my $error = $rw->error();
                printf "[%s] Returned error: %s\n", $dev, $error if $error;
            }
        } else {
            printf "[%s] Saving configuration not supported.\n", $dev;
        }
    }

    printf "Finished configuration saving at %s.\n", scalar(localtime);
}

=back

=cut

sub test {
}

sub header{
    print "n e t  d i s c o\n";
    print '-'x50 . "\n";
}

sub version {
    &header;
    my $perl = defined $^V ? join('.',map {ord} split(//,$^V)) : $];
    print "Netdisco Version   : $VERSION\n";
    print "SNMP::Info Version : $SNMP::Info::VERSION\n";
    print "Net-SNMP Version   : $SNMP::VERSION\n";
    print "Perl Version       : $perl\n";
    exit;
}

sub usage{
    print <<"_end_usage_";
Netdisco - Network Discovery and Management ($VERSION)

netdisco [Options] Command(s)

Options:
    -b --batchmode              Batch Mode - Redirect stdout to log files
    -C --configfile   file      Specify path to config file
    -n --nodestoo               Delete nodes when using --expiredevice
    -N --newonly                For --discoverall and --discoverfile
    -P --port         port      Restrict --expirenodes to a single port 
    -V --archive                Archive instead of deleting in --expirenodes
    -D --debug                  DEBUG - Copious output
    -L --nologging              DEBUG - No logging
    -S --dumpsql                DEBUG - Dump SQL commands

Network Commands:
    -r --discoverall  device    Discover network starting from device
    -F --discoverfile file      Discover/Refresh devices from file
    -T --topofile               Import Topology info from topofile
    -R --refresh                Refresh all Devices
    -m --macwalk                Macsuck whole network
    -a --arpwalk                Arpnip whole network
    -w --nbtwalk                Nbtwalk whole network

Device Commands:
    -d --discover     device    Refresh single device
    -M --macsuck      device    Macsuck single device
    -A --arpnip       device    Arpnip  single device
    -W --nbtstat      node      Nbtstat single node
    -E --expiredevice device    Delete device
    -e --expirenodes  device    Delete/Archive nodes on a device
    --expire-nodes-subnet
                      subnet    Runs --expirenodes for all devices in a subnet
    -I --expireips              Expire IPs not seen on switch ports 
    -i --changeip     old new   Change IP address of device and its nodes

Administration:
    -B --backup                 Backups data and runs database cleanup 
    -g --graph                  Create network map files 
    -j --saveconfigs  minutes   Saves configs on devices modified by jobs
    -k --cleanalias             Deletes devices listed as aliases of another
    -K --cleannodes             Clean out nodes listed on uplink ports
    -O --oui                    Import oui.txt into Netdisco
    -p (start,stop,status,restart) Admin Daemon Control
    -u [user] [pw] [port] [admin]  Add/Change User 
    -v --version                Version info for Netdisco components

_end_usage_
    exit;
}

=head1 COPYRIGHT AND LICENCE

Changes in code from 0.92 on:
Copyright (c) 2003-2010 Max Baker and the Netdisco Developer Team - All Rights Reserved

Original Code:
Copyright (c) 2002,2003 Regents of the University of California
All rights reserved.

Redistribution and use in source and binary forms, with or without 
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright notice,
      this list of conditions and the following disclaimer.
    * Redistributions in binary form must reproduce the above copyright notice,
      this list of conditions and the following disclaimer in the documentation
      and/or other materials provided with the distribution.
    * Neither the name of the University of California, Santa Cruz nor the 
      names of its contributors may be used to endorse or promote products 
      derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
